line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package IO::ReadPreProcess; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
# The idea is to provide an 'intelligent' bottom end read function for scripts. |
4
|
|
|
|
|
|
|
# Read lines, process .if/.else/.fi, do .include .let .print - and more. |
5
|
|
|
|
|
|
|
# It provides IO::Handle-ish functions to slot in easily to most scripts. |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
# Author: Alain D D Williams March 2015, 2016, 2017 Copyright (C) the author. |
8
|
|
|
|
|
|
|
# SCCS: @(#)ReadPreProcess.pm 1.13 08/03/17 15:16:04 |
9
|
|
|
|
|
|
|
|
10
|
1
|
|
|
1
|
|
21982
|
use 5.006; |
|
1
|
|
|
|
|
3
|
|
11
|
1
|
|
|
1
|
|
5
|
use strict; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
19
|
|
12
|
1
|
|
|
1
|
|
5
|
use warnings; |
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
46
|
|
13
|
|
|
|
|
|
|
#use Data::Dumper; |
14
|
1
|
|
|
1
|
|
5
|
use IO::File; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
97
|
|
15
|
1
|
|
|
1
|
|
250
|
use IO::Pipe; |
|
1
|
|
|
|
|
899
|
|
|
1
|
|
|
|
|
32
|
|
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
our $errstr; # Error string |
18
|
|
|
|
|
|
|
|
19
|
1
|
|
|
1
|
|
5
|
use Math::Expression; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
3927
|
|
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
our $VERSION = 0.84; |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
# Control directive recognised by getline(): |
24
|
|
|
|
|
|
|
my %ctlDirectives = map { $_ => 1 } qw/ break case close continue do done echo else elseif elsif endswitch error eval exit |
25
|
|
|
|
|
|
|
fi for if include last let local next noop out print read return set sub switch test unless until while /; |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
# Directives that can be used in a condition: |
28
|
|
|
|
|
|
|
my %condDirectives = map { $_ => 1 } qw/ include read test /; |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
# Need to test for this ... all except first line |
31
|
|
|
|
|
|
|
my %forbidden = map { $_ => 1 } qw/ function sub /; |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
# Block pairs: start & ends |
34
|
|
|
|
|
|
|
my %blkPairs = qw/ sub done while done until done for done if fi unless fi /; |
35
|
|
|
|
|
|
|
my %endings = map { $_ => 1 } qw/ done fi /; |
36
|
|
|
|
|
|
|
my %loops = map { $_ => 1 } qw/ while until for /; |
37
|
|
|
|
|
|
|
my %makeExpr = map { $_ => 1 } qw/ let if unless elsif elseif while until for /; |
38
|
|
|
|
|
|
|
my %options = map { $_ => 1 } qw/ trace /; |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
# Math variables (others see POD below): |
41
|
|
|
|
|
|
|
# _FileNames - array of open file names |
42
|
|
|
|
|
|
|
# _LineNumbers - array of open file names |
43
|
|
|
|
|
|
|
# _IncludeDepth - how many files open |
44
|
|
|
|
|
|
|
# _FileName _LineNumber - current ones |
45
|
|
|
|
|
|
|
# The arrays are to allow the generation of a traceback. |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
# Properties not described in new |
48
|
|
|
|
|
|
|
# Information about the current file is kept as references so that it can be pushed down a stack (think: .include) and popped when it is closed. |
49
|
|
|
|
|
|
|
# |
50
|
|
|
|
|
|
|
# Lines contains refs else we would need to update before pushing |
51
|
|
|
|
|
|
|
sub new |
52
|
|
|
|
|
|
|
{ |
53
|
59
|
|
|
59
|
1
|
65497
|
my $class = shift; |
54
|
59
|
|
|
|
|
941
|
my $self = bless { |
55
|
|
|
|
|
|
|
FrameStk => [], # Frames |
56
|
|
|
|
|
|
|
Frame => undef, # Reference to current frame (last in FrameStk) |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
subs => {}, # Keys are known sub |
59
|
|
|
|
|
|
|
Streams => {}, # Input streams |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
out => "", # Name of current output stream, empty string is return line to program |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
# Public properties: |
64
|
|
|
|
|
|
|
MaxLoopCount => 50, # Max times that a loop can go round |
65
|
|
|
|
|
|
|
Raw => 0, # Return input as it is seen |
66
|
|
|
|
|
|
|
PipeOK => 0, # True if allowed to open a pipe |
67
|
|
|
|
|
|
|
Trim => 1, # Trim input lines |
68
|
|
|
|
|
|
|
OnError => 'warn', # Can set to: warn, die, '' |
69
|
|
|
|
|
|
|
OutStreams => {}, # Key: name, value: Stream |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
Place => '??', # Last read location: current file/line# |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
DirStart => '.', # Directive start sequence |
74
|
|
|
|
|
|
|
TopIsFd => 0, # First file pre-opened, ie Fd passed to open() |
75
|
|
|
|
|
|
|
Error => 0, # Set true on error, functions then just return undef |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
trace => 0, # 1 trace directives, 2 trace generated input |
78
|
|
|
|
|
|
|
@_ |
79
|
|
|
|
|
|
|
}, $class; |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
# These output streams are given for free: |
82
|
59
|
50
|
|
|
|
484
|
$self->{OutStreams}->{STDOUT} = *STDOUT{IO} unless( defined($self->{OutStreams}->{STDOUT})); |
83
|
59
|
50
|
|
|
|
265
|
$self->{OutStreams}->{STDERR} = *STDERR{IO} unless( defined($self->{OutStreams}->{STDERR})); |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
# Produce an escaped version of the directive start string. All the RE special prefix with a backslash. |
86
|
|
|
|
|
|
|
# This will be used at the start of an RE but we want it taken literally. |
87
|
59
|
50
|
|
|
|
179
|
unless(defined($self->{DirStartRE})) { |
88
|
59
|
|
|
|
|
146
|
$self->{DirStartRE} = $self->{DirStart}; |
89
|
59
|
|
|
|
|
430
|
$self->{DirStartRE} =~ s/([\$.()\[\]*+?\\^|])/\\$1/g; |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
# This is not worth it: |
92
|
|
|
|
|
|
|
# $self->{dirLineRE} = qr/^($self->{DirStartRE})(\w*)\s*(.*)/; |
93
|
|
|
|
|
|
|
# $self->{commentRE} = qr/^$self->{DirStartRE}#/; |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
$self->{Math} = new Math::Expression(PermitLoops => 1, EnablePrintf => 1) |
96
|
59
|
50
|
|
|
|
535
|
unless(defined $self->{Math}); |
97
|
|
|
|
|
|
|
|
98
|
59
|
50
|
|
|
|
3137
|
unless($self->{Math}->{VarHash}->{_Initialised}) { |
99
|
59
|
|
|
|
|
243
|
$self->{Math}->ParseToScalar('_FileNames := EmptyList; _LineNumbers := EmptyList; _IncludeDepth := 0; _Initialised := 1'); |
100
|
59
|
|
|
|
|
73638
|
$self->{Math}->ParseToScalar('_ARGS := (); _ := _EOF := 0'); |
101
|
59
|
|
|
|
|
47386
|
$self->{Math}->ParseToScalar('_CountGen := _CountSkip := _CountDirect := _CountFrames := _CountOpen := 0'); |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
# We do some things a lot - compile them, that is the expensive part: |
105
|
59
|
|
|
|
|
52277
|
my %math = ( |
106
|
|
|
|
|
|
|
SetLineMath => '_LineNumbers[-1] := _LineNumber', |
107
|
|
|
|
|
|
|
m_openFrame => 'push(_FileNames, _FileName); push(_LineNumbers, _LineNumber); ++_IncludeDepth', |
108
|
|
|
|
|
|
|
m_closeFrame => 'pop(_FileNames); pop(_LineNumbers); --_IncludeDepth; _FileName := ""; _LineNumber := 0; if(count(_FileNames)){_FileName := _FileNames[-1]; _LineNumber := _LineNumbers[-1]}', |
109
|
|
|
|
|
|
|
); |
110
|
|
|
|
|
|
|
|
111
|
59
|
|
|
|
|
309
|
while (my($p, $e) = each %math) { |
112
|
177
|
|
|
|
|
161294
|
$self->{$p} = $self->{Math}->Parse($e); |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
# Take some out - cause problems if there since we try to set them again |
116
|
59
|
|
|
|
|
80923
|
my %opts; |
117
|
59
|
|
|
|
|
213
|
for (qw/ Fd File /) { |
118
|
118
|
100
|
|
|
|
340
|
if(defined($self->{$_})) { |
119
|
61
|
|
|
|
|
194
|
$opts{$_} = $self->{$_}; |
120
|
61
|
|
|
|
|
197
|
delete $self->{$_}; |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
# Attempt to open the file if passed: |
125
|
59
|
50
|
|
|
|
182
|
if(defined($opts{File})) { |
126
|
59
|
100
|
|
|
|
166
|
if(defined($opts{Fd})) { |
127
|
|
|
|
|
|
|
# Already open, note name, push to include stack: |
128
|
2
|
|
|
|
|
11
|
$self->openFrame(binmode => '', %opts, Name => $opts{File}, LineNumber => 0, Generate => 1, ReturnFrom => 1); |
129
|
|
|
|
|
|
|
} else { |
130
|
57
|
50
|
|
|
|
281
|
return undef unless($self->open(binmode => '', %opts)); |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
$self |
135
|
59
|
|
|
|
|
303
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
# Open a file. Args: |
138
|
|
|
|
|
|
|
# * File - a name - mandatory |
139
|
|
|
|
|
|
|
# * Fd - a file handle that it is already open on - optional |
140
|
|
|
|
|
|
|
# Return $self on OK, undef on error |
141
|
|
|
|
|
|
|
# Pushes the current file on a stack that allows restore by close() |
142
|
|
|
|
|
|
|
sub open |
143
|
|
|
|
|
|
|
{ |
144
|
57
|
|
|
57
|
1
|
127
|
my $self = shift; |
145
|
57
|
|
|
|
|
278
|
my %args = @_; |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
return $self->SetError('open() must be given File argument', 1) |
148
|
57
|
50
|
|
|
|
209
|
if( !defined $args{File}); |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
# But elsewhere File is called Name - which could be a sub name |
151
|
57
|
|
|
|
|
163
|
$args{Name} = $args{File}; |
152
|
57
|
|
|
|
|
125
|
delete $args{File}; |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
# Get it open on $self->{Fd} |
155
|
57
|
|
|
|
|
113
|
my $Fd; |
156
|
57
|
50
|
|
|
|
162
|
if( !defined $args{Fd}) { |
157
|
57
|
50
|
|
|
|
202
|
return undef unless($Fd = $self->openFile($args{Name})); |
158
|
|
|
|
|
|
|
} else { |
159
|
|
|
|
|
|
|
# Use already opened Fd |
160
|
0
|
|
|
|
|
0
|
$Fd = $args{Fd}; |
161
|
0
|
|
|
|
|
0
|
$self->{TopIsFd} = 1; |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
|
164
|
57
|
|
|
|
|
313
|
$self->openFrame(%args, Fd => $Fd, LineNumber => 0, Generate => 1, ReturnFrom => 1); |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
# Open a file, apply any binmode, return FD |
168
|
|
|
|
|
|
|
sub openFile |
169
|
|
|
|
|
|
|
{ |
170
|
87
|
|
|
87
|
0
|
266
|
my ($self, $name) = @_; |
171
|
87
|
|
|
|
|
137
|
my $Fd; |
172
|
|
|
|
|
|
|
|
173
|
87
|
50
|
|
|
|
778
|
return $self->SetError("Open of file '$name' failed: $! at $self->{Place}") |
174
|
|
|
|
|
|
|
unless($Fd = IO::File->new($name, 'r')); |
175
|
|
|
|
|
|
|
|
176
|
87
|
|
|
|
|
10112
|
$self->{Math}->{VarHash}->{_CountOpen}->[0]++; |
177
|
|
|
|
|
|
|
|
178
|
87
|
50
|
|
|
|
352
|
$Fd->binmode($self->{Frame}->{binmode}) if($self->{Frame}->{binmode}); |
179
|
|
|
|
|
|
|
|
180
|
87
|
|
|
|
|
291
|
$Fd |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
# Internal routine. |
184
|
|
|
|
|
|
|
# Assign the new values and push onto their own stack so that, after a later open() |
185
|
|
|
|
|
|
|
# it can be popped by a close() of that later file. |
186
|
|
|
|
|
|
|
sub openFrame |
187
|
|
|
|
|
|
|
{ |
188
|
458
|
|
|
458
|
0
|
908
|
my $self = shift; |
189
|
458
|
|
|
|
|
2446
|
my %args = @_; |
190
|
458
|
|
|
|
|
1270
|
my $vh = $self->{Math}->{VarHash}; |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
# Create the new frame: |
193
|
458
|
|
|
|
|
2345
|
my %f = ( PushedInput => [], @_ ); |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
# Create var _ARGS if argument Args: |
196
|
458
|
100
|
|
|
|
1231
|
if(defined($args{Args})) { |
197
|
199
|
|
|
|
|
799
|
$f{LocalVars} = {_ARGS => $vh->{_ARGS}}; |
198
|
199
|
|
|
|
|
454
|
delete $vh->{_ARGS}; |
199
|
199
|
|
|
|
|
424
|
$vh->{_ARGS} = $args{Args}; |
200
|
199
|
|
|
|
|
334
|
delete $f{Args}; |
201
|
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
# One of Code or Fd must be passed |
204
|
|
|
|
|
|
|
# Must have the following, if not set copy from enclosing frame: |
205
|
458
|
|
|
|
|
1108
|
for my $p (qw/ Code CodeLine Name LineNumber Fd Generate binmode /) { |
206
|
|
|
|
|
|
|
|
207
|
3206
|
100
|
|
|
|
6231
|
$f{$p} = $args{$p} if(defined($args{$p})); |
208
|
|
|
|
|
|
|
|
209
|
3206
|
100
|
100
|
|
|
10077
|
if(defined($self->{Frame}) && defined($self->{Frame}->{$p})) { |
210
|
2281
|
100
|
|
|
|
6229
|
$f{$p} = $self->{Frame}->{$p} unless(defined($f{$p})); |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
} |
213
|
|
|
|
|
|
|
|
214
|
458
|
|
|
|
|
1794
|
$f{FrameStart} = "$f{Name}:$f{LineNumber}"; |
215
|
|
|
|
|
|
|
|
216
|
458
|
|
|
|
|
741
|
push(@{$self->{FrameStk}}, \%f); |
|
458
|
|
|
|
|
1254
|
|
217
|
458
|
|
|
|
|
930
|
$self->{Frame} = \%f; |
218
|
|
|
|
|
|
|
|
219
|
458
|
|
|
|
|
977
|
$vh->{_CountFrames}->[0]++; |
220
|
458
|
|
|
|
|
1125
|
$vh->{_LineNumber}->[0] = $f{LineNumber}; |
221
|
458
|
|
|
|
|
951
|
$vh->{_FileName}->[0] = $f{Name}; |
222
|
458
|
|
|
|
|
1915
|
$self->{Math}->EvalToScalar($self->{m_openFrame}); |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
|
225
|
458
|
|
|
|
|
130417
|
$self; # success |
226
|
|
|
|
|
|
|
} |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
# Close a file - this might mean closeing more than 1 frame |
229
|
|
|
|
|
|
|
# An important block is a (.include) file. |
230
|
|
|
|
|
|
|
# Check $self->{Fd} for there being an open file. |
231
|
|
|
|
|
|
|
# Return false on error |
232
|
|
|
|
|
|
|
sub close |
233
|
|
|
|
|
|
|
{ |
234
|
130
|
|
|
130
|
1
|
298
|
my $self = shift; |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
# Unwind until we find a ReturnFrom: |
237
|
130
|
|
|
|
|
249
|
my $rf; |
238
|
130
|
|
|
|
|
223
|
do { |
239
|
134
|
|
|
|
|
317
|
$rf = $self->{Frame}->{ReturnFrom}; |
240
|
|
|
|
|
|
|
return undef |
241
|
134
|
50
|
|
|
|
369
|
unless($self->closeFrame); |
242
|
|
|
|
|
|
|
} until($rf); |
243
|
|
|
|
|
|
|
|
244
|
130
|
|
|
|
|
380
|
$self |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
# Closes the current frame, pops back the previous one - if there was one |
248
|
|
|
|
|
|
|
sub closeFrame |
249
|
|
|
|
|
|
|
{ |
250
|
458
|
|
|
458
|
0
|
781
|
my $self = shift; |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
return $self->SetError("Cannot close when there is not a frame open", 1) |
253
|
458
|
50
|
66
|
|
|
1596
|
unless(defined $self->{Frame}->{Code} or defined $self->{Frame}->{Fd}); |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
# If error: this will be an OS level error |
256
|
458
|
50
|
|
|
|
1324
|
return $self->SetError("IO::File I/O error: $!") |
257
|
|
|
|
|
|
|
if($self->error); |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
# Don't close - we don't want to close STDIN, could cause problems |
260
|
|
|
|
|
|
|
# Rely on the IO::File object for files that we have opened ourselves being unreferenced and thus closed. |
261
|
|
|
|
|
|
|
# $self->{Fd}->close; |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
# Pop back the previous state/file - if there was one |
264
|
|
|
|
|
|
|
# Pop the description/state for the file just closed and assign |
265
|
|
|
|
|
|
|
# state for the file just revealed - what is now at the top of the stack: |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
# Pop any local vars: |
268
|
458
|
100
|
|
|
|
1192
|
if($self->{Frame}->{LocalVars}) { |
269
|
201
|
|
|
|
|
392
|
my $alist = $self->{Frame}->{LocalVars}; |
270
|
201
|
|
|
|
|
364
|
my $vh = $self->{Math}->{VarHash}; |
271
|
201
|
|
|
|
|
932
|
while (my ($k, undef) = each %$alist) { |
272
|
453
|
|
|
|
|
940
|
delete($vh->{$k}); |
273
|
453
|
100
|
|
|
|
1677
|
$vh->{$k} = $alist->{$k} if(defined($alist->{$k})); |
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
} |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
|
278
|
458
|
|
|
|
|
674
|
my $old = pop(@{$self->{FrameStk}}); |
|
458
|
|
|
|
|
957
|
|
279
|
458
|
|
|
|
|
950
|
$self->{Frame} = $self->{FrameStk}->[-1]; |
280
|
|
|
|
|
|
|
|
281
|
458
|
100
|
100
|
|
|
1513
|
$self->{Frame}->{CodeLine} = $old->{CodeLine} if($self->{Frame}->{Code} && $old->{CpMove}); |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
# Get arith variables in sync |
284
|
458
|
|
|
|
|
1475
|
$self->{Math}->EvalToScalar($self->{m_closeFrame}); |
285
|
|
|
|
|
|
|
|
286
|
458
|
|
|
|
|
266761
|
$self |
287
|
|
|
|
|
|
|
} |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
# This package is intended to read text files - so straight binmode is prob not wanted. |
290
|
|
|
|
|
|
|
# But binmode is also used to allow different encoding - eg :utf8 |
291
|
|
|
|
|
|
|
# Return true on success, on error undef with error in $! |
292
|
|
|
|
|
|
|
# Record the mode in the frame, inherited by child frames |
293
|
|
|
|
|
|
|
sub binmode |
294
|
|
|
|
|
|
|
{ |
295
|
0
|
|
|
0
|
1
|
0
|
my ($self, $mode) = @_; |
296
|
|
|
|
|
|
|
|
297
|
0
|
0
|
|
|
|
0
|
return $self->SetError("binmode: a file has not been opened", 1) unless $self->{Frame}->{Fd}; |
298
|
|
|
|
|
|
|
|
299
|
0
|
|
|
|
|
0
|
$self->{Frame}->{binmode} = $mode; |
300
|
|
|
|
|
|
|
|
301
|
0
|
|
|
|
|
0
|
$self->{Frame}->{Fd}->binmode($mode); # Pass the call straight down |
302
|
|
|
|
|
|
|
} |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
# Return 1 if the next read will return EOF or the file is not open: |
305
|
|
|
|
|
|
|
sub eof |
306
|
|
|
|
|
|
|
{ |
307
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
308
|
0
|
0
|
|
|
|
0
|
return 1 unless($self->{Fd}); |
309
|
0
|
|
|
|
|
0
|
$self->{Fd}->eof; |
310
|
|
|
|
|
|
|
} |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
# Get the name of the file to open |
313
|
|
|
|
|
|
|
# Args: |
314
|
|
|
|
|
|
|
# * name |
315
|
|
|
|
|
|
|
# * just return undef if cannot open, don't print error - optional |
316
|
|
|
|
|
|
|
# First process escapes |
317
|
|
|
|
|
|
|
# If it starts '$', the next word is a variable, use the value(s) like $PATH - search |
318
|
|
|
|
|
|
|
# Else resolve |
319
|
|
|
|
|
|
|
sub ResolveFilename |
320
|
|
|
|
|
|
|
{ |
321
|
32
|
|
|
32
|
0
|
84
|
my ($self, $name, $noerr) = @_; |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
# If it starts '$' |
324
|
32
|
100
|
|
|
|
102
|
if(substr($name, 0, 1) eq '$') { |
325
|
5
|
50
|
|
|
|
25
|
return $self->SetError("Bad syntax include file name: '$name' at $self->{Place}", 1) |
326
|
|
|
|
|
|
|
unless($name =~ m:^\$(\w+)(/.+)$:i); |
327
|
5
|
|
|
|
|
17
|
my ($var, $rest) = ($1, $2); |
328
|
|
|
|
|
|
|
|
329
|
5
|
|
|
|
|
11
|
my ($pt, @val); |
330
|
|
|
|
|
|
|
return $self->SetError("Bad expression in include: '$name' at $self->{Place}", 1) |
331
|
5
|
50
|
33
|
|
|
17
|
unless(($pt = $self->{Math}->Parse($var)) && (@val = $self->{Math}->Eval($pt))); |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
# Search down path: |
334
|
5
|
|
|
|
|
775
|
for my $pref (@val) { |
335
|
12
|
|
|
|
|
40
|
my $fp = $self->GetPath("$pref$rest"); |
336
|
12
|
50
|
|
|
|
26
|
return undef unless $fp; |
337
|
12
|
100
|
|
|
|
253
|
return $fp # Grab it if it exists |
338
|
|
|
|
|
|
|
if(-e $fp); |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
|
341
|
0
|
0
|
|
|
|
0
|
return undef if($noerr); |
342
|
|
|
|
|
|
|
|
343
|
0
|
|
|
|
|
0
|
return $self->SetError("Cannot find a file in search '$name'. $var='@val' at $self->{Place}", 1) |
344
|
|
|
|
|
|
|
} |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
# Plain file name: |
347
|
27
|
|
|
|
|
112
|
return $self->GetPath($name); |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
# If it is absolute (starts '/'): accept |
351
|
|
|
|
|
|
|
# If it starts '#' it is relative to the process's CWD, remove '#' & accept |
352
|
|
|
|
|
|
|
# The rest are relative to the current file name: prepend any directory name |
353
|
|
|
|
|
|
|
# Don't try to canonicalise a/b/../c to a/c - think symlinks. |
354
|
|
|
|
|
|
|
sub GetPath |
355
|
|
|
|
|
|
|
{ |
356
|
39
|
|
|
39
|
0
|
86
|
my ($self, $name) = @_; |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
# Absolute path: |
359
|
39
|
100
|
|
|
|
135
|
return $name if index($name, '/') == 0; |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
# Relative to our CWD: |
362
|
35
|
100
|
|
|
|
91
|
if(substr($name, 0, 1) eq '#') { |
363
|
9
|
|
|
|
|
23
|
$name = substr($name, 1); # Remove # |
364
|
9
|
|
|
|
|
21
|
$name = substr($name, 1) # Remove / after # |
365
|
|
|
|
|
|
|
while(substr($name, 0, 1) eq '/'); |
366
|
9
|
|
|
|
|
20
|
return $name; |
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
# Everything else is relative to the current file |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
# Cannot have a relative name if the current file was passed as Fd |
372
|
|
|
|
|
|
|
return $self->SetError("Cannot include file relative to file descriptor. '$name' at $self->{Place}", 1) |
373
|
26
|
50
|
33
|
|
|
97
|
if($self->{TopIsFd} && @{$self->{FrameStk}} == 1); |
|
0
|
|
|
|
|
0
|
|
374
|
|
|
|
|
|
|
# **** This refers to self->file - on stack & called Name |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
# Find the last opened file name |
377
|
26
|
|
|
|
|
47
|
my $last; |
378
|
|
|
|
|
|
|
return undef |
379
|
26
|
50
|
|
|
|
106
|
unless($last = $self->GetLastFileName); |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
# Note RE ensures that $currDir is '' if $last does not contain '/': |
382
|
26
|
|
|
|
|
196
|
my ($currDir) = $last =~ m:^(.*?/?)[^/]+$:; |
383
|
|
|
|
|
|
|
|
384
|
26
|
|
|
|
|
106
|
$currDir . $name |
385
|
|
|
|
|
|
|
} |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
# Get the name of the last file opened, dig down the stack |
388
|
|
|
|
|
|
|
sub GetLastFileName |
389
|
|
|
|
|
|
|
{ |
390
|
26
|
|
|
26
|
0
|
50
|
my ($self) = @_; |
391
|
|
|
|
|
|
|
|
392
|
26
|
|
|
|
|
41
|
my $frames = @{$self->{FrameStk}}; |
|
26
|
|
|
|
|
66
|
|
393
|
|
|
|
|
|
|
|
394
|
26
|
|
|
|
|
78
|
while(--$frames >= 0) { |
395
|
48
|
100
|
|
|
|
177
|
return $self->{FrameStk}->[$frames]->{Name} if(exists($self->{FrameStk}->[$frames]->{Fd})); |
396
|
|
|
|
|
|
|
} |
397
|
|
|
|
|
|
|
|
398
|
0
|
|
|
|
|
0
|
return $self->SetError("Cannot find previous file name at $self->{Place}", 1); |
399
|
|
|
|
|
|
|
} |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
# Line parsed for escapes: \0 \e \v{varname}. varname is: /\w+/i |
402
|
|
|
|
|
|
|
# Arg is a string that is processed & returned |
403
|
|
|
|
|
|
|
sub ProcEscapes |
404
|
|
|
|
|
|
|
{ |
405
|
2857
|
|
|
2857
|
0
|
5162
|
my ($self, $arg) = @_; |
406
|
|
|
|
|
|
|
|
407
|
2857
|
|
|
|
|
4111
|
my $ret = ''; |
408
|
|
|
|
|
|
|
|
409
|
2857
|
|
|
|
|
7641
|
while($arg =~ s/^([^\\]*)\\(.)//) { |
410
|
838
|
|
|
|
|
2396
|
$ret .= $1; |
411
|
838
|
50
|
|
|
|
3050
|
if($2 eq '0') { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
412
|
|
|
|
|
|
|
; # nothing |
413
|
|
|
|
|
|
|
} elsif($2 eq 'e') { |
414
|
1
|
|
|
|
|
3
|
$ret .= '\\'; |
415
|
|
|
|
|
|
|
} elsif($2 eq 'v') { |
416
|
837
|
50
|
|
|
|
3412
|
return $self->SetError("Invalid escape \\v$arg at $self->{Place}", 1) |
417
|
|
|
|
|
|
|
unless($arg =~ s/^{(\w+|\w+\[\w+\])}//i); |
418
|
837
|
|
|
|
|
1968
|
my $vn = $1; |
419
|
837
|
|
|
|
|
3035
|
my $vv = $self->{Math}->ParseToScalar($1); |
420
|
837
|
50
|
|
|
|
145678
|
return $self->SetError("Invalid variable in \\v{$1} at $self->{Place}", 1) |
421
|
|
|
|
|
|
|
unless(defined($vv)); |
422
|
837
|
|
|
|
|
3121
|
$ret .= $vv; |
423
|
|
|
|
|
|
|
} else { |
424
|
0
|
|
|
|
|
0
|
return $self->SetError("Invalid escape \\$2 at $self->{Place}", 1); |
425
|
|
|
|
|
|
|
} |
426
|
|
|
|
|
|
|
} |
427
|
2857
|
50
|
|
|
|
5323
|
return $self->SetError("Trailing \\ on line at $self->{Place}", 1) |
428
|
|
|
|
|
|
|
if($arg =~ /\\/); |
429
|
|
|
|
|
|
|
|
430
|
2857
|
|
|
|
|
8354
|
$ret . $arg; |
431
|
|
|
|
|
|
|
} |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
# Split the argument string on spaces into an array of strings. |
434
|
|
|
|
|
|
|
# If a portion starts with a quote, it may contain a space |
435
|
|
|
|
|
|
|
# If $doEsc each result is processed by ProcEscapes() |
436
|
|
|
|
|
|
|
# Return the result or false |
437
|
|
|
|
|
|
|
sub SplitArgs |
438
|
|
|
|
|
|
|
{ |
439
|
595
|
|
|
595
|
0
|
1450
|
my ($self, $arg, $doEsc) = @_; |
440
|
595
|
|
|
|
|
967
|
my @args = (); |
441
|
|
|
|
|
|
|
|
442
|
595
|
|
|
|
|
2056
|
$arg =~ s/^\s*//; |
443
|
595
|
|
|
|
|
1572
|
while($arg ne '') { |
444
|
2469
|
|
|
|
|
4234
|
my $c1 = substr($arg, 0, 1); |
445
|
2469
|
100
|
100
|
|
|
6701
|
if($c1 eq '"' or $c1 eq "'") { |
446
|
|
|
|
|
|
|
# Extract the string delimited by quotes |
447
|
10
|
50
|
|
|
|
117
|
return $self->SetError("Bad quoted string at $self->{Place}", 1) |
448
|
|
|
|
|
|
|
unless($arg =~ s/^(["'])((\\{2})*|(.*?[^\\](\\{2})*))\1\s*//); |
449
|
10
|
|
|
|
|
27
|
my $m = $2; |
450
|
10
|
|
|
|
|
26
|
$m =~ s/\\([\\'"])/$1/g; # Remove embedded escapes, eg: \" => " |
451
|
10
|
|
|
|
|
28
|
push(@args, $m); |
452
|
|
|
|
|
|
|
} else { |
453
|
2459
|
|
|
|
|
6769
|
$arg =~ s/^(\S+)\s*//; |
454
|
2459
|
|
|
|
|
6991
|
push(@args, $1); |
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
} |
458
|
|
|
|
|
|
|
|
459
|
595
|
100
|
|
|
|
1598
|
@args = map { $self->ProcEscapes($_) } @args if($doEsc); |
|
2411
|
|
|
|
|
4540
|
|
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
@args |
462
|
595
|
|
|
|
|
1961
|
} |
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
# Read & store a sub or function to hash in $self->{subs}->{Name} |
465
|
|
|
|
|
|
|
# Don't start a frame since we are just reading this in |
466
|
|
|
|
|
|
|
# Return true if OK |
467
|
|
|
|
|
|
|
sub readSub |
468
|
|
|
|
|
|
|
{ |
469
|
38
|
|
|
38
|
0
|
116
|
my ($self, $direc, $InLine, $arg) = @_; |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
# Check that $self->{Frame}->{Fd} is an open file |
472
|
|
|
|
|
|
|
|
473
|
38
|
|
|
|
|
82
|
my $code = { }; |
474
|
|
|
|
|
|
|
|
475
|
38
|
|
|
|
|
73
|
my @args; |
476
|
|
|
|
|
|
|
|
477
|
38
|
50
|
|
|
|
101
|
return $self->SetError("Missing $direc name at $self->{Place}", 1) unless($arg ne ''); |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
# Also need to check that name & args are IDs |
480
|
38
|
50
|
|
|
|
123
|
return undef unless(@args = $self->SplitArgs($arg, 0)); |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
# First is the name: |
483
|
38
|
|
|
|
|
125
|
$code->{Name} = shift @args; |
484
|
|
|
|
|
|
|
return $self->SetError("Error: bad sub name '$code->{Name}' at $self->{Place}") |
485
|
38
|
50
|
|
|
|
190
|
unless($code->{Name} =~ /^\w+$/); |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
return $self->SetError("Error: Redefinition of sub '$code->{Name}' at $self->{Place}") |
488
|
38
|
50
|
|
|
|
144
|
if(exists($self->{subs}->{$code->{Name}})); |
489
|
|
|
|
|
|
|
|
490
|
38
|
|
|
|
|
136
|
$self->{subs}->{$code->{Name}} = $code; |
491
|
38
|
|
|
|
|
88
|
$code->{ArgNames} = @args; |
492
|
|
|
|
|
|
|
|
493
|
|
|
|
|
|
|
# sub args can have names: |
494
|
38
|
100
|
|
|
|
111
|
$code->{ArgNames} = \@args if(@args); |
495
|
|
|
|
|
|
|
|
496
|
38
|
|
|
|
|
105
|
$code->{Block} = $direc; # Info only |
497
|
|
|
|
|
|
|
|
498
|
38
|
|
|
|
|
141
|
$self->ReadBlock($InLine, $code); |
499
|
|
|
|
|
|
|
|
500
|
38
|
|
|
|
|
74
|
$code->{LastLine}--; # Remove .done |
501
|
38
|
|
|
|
|
61
|
$code->{FirstLine}++; # Remove .sub |
502
|
|
|
|
|
|
|
|
503
|
38
|
|
|
|
|
129
|
1 |
504
|
|
|
|
|
|
|
} |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
# $direct is while/until/for |
507
|
|
|
|
|
|
|
# $arg is loop condition/rest-of-line |
508
|
|
|
|
|
|
|
# May start: -innn to specify max iterations |
509
|
|
|
|
|
|
|
# **** THINKS **** |
510
|
|
|
|
|
|
|
# Loops are found in 2 ways: |
511
|
|
|
|
|
|
|
# (1) Reading from a {Fd} - ie in getline() |
512
|
|
|
|
|
|
|
# (2) When in a sub or an enclosing loop |
513
|
|
|
|
|
|
|
# We always buffer a loop, so the only difference is where/how it is found |
514
|
|
|
|
|
|
|
# The purpose of this sub is for case (1), need to initiate a buffer creation |
515
|
|
|
|
|
|
|
# If (1) read into a buffer/code and return a ref to the code |
516
|
|
|
|
|
|
|
# If (2) set up $code and return that |
517
|
|
|
|
|
|
|
sub ReadLoop |
518
|
|
|
|
|
|
|
{ |
519
|
17
|
|
|
17
|
0
|
94
|
my ($self, $direc, $InLine, $arg) = @_; |
520
|
|
|
|
|
|
|
|
521
|
17
|
|
|
|
|
232
|
my $frame = $self->{Frame}; |
522
|
|
|
|
|
|
|
|
523
|
17
|
|
|
|
|
70
|
my $code = { Block => $direc }; |
524
|
|
|
|
|
|
|
|
525
|
17
|
|
|
|
|
93
|
$self->ReadBlock($InLine, $code); |
526
|
|
|
|
|
|
|
|
527
|
17
|
|
|
|
|
96
|
$code |
528
|
|
|
|
|
|
|
} |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
# Read a block (sub or loop) to arg \%code |
531
|
|
|
|
|
|
|
# If this finds a loop - note it as within what we read -- works for sub & nested loops |
532
|
|
|
|
|
|
|
# $InLine is the line just read |
533
|
|
|
|
|
|
|
sub ReadBlock |
534
|
|
|
|
|
|
|
{ |
535
|
55
|
|
|
55
|
0
|
157
|
my ($self, $InLine, $code) = @_; |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
# Record where this was found: |
538
|
55
|
|
|
|
|
256
|
my $h={ FileName => $self->{Frame}->{Name}, FileLine => $self->{Frame}->{LineNumber}}; |
539
|
55
|
|
|
|
|
296
|
while (my($k,$v)= (each %$h)){ |
540
|
110
|
|
|
|
|
399
|
$code->{$k} = $v; |
541
|
|
|
|
|
|
|
} |
542
|
|
|
|
|
|
|
|
543
|
55
|
|
|
|
|
238
|
$code->{start} = "$code->{FileName}:$code->{FileLine}"; |
544
|
|
|
|
|
|
|
|
545
|
55
|
|
|
|
|
135
|
my $started = "started $code->{start}"; |
546
|
55
|
|
|
|
|
115
|
my @blocks; |
547
|
|
|
|
|
|
|
|
548
|
55
|
|
|
|
|
100
|
my $frame = $self->{Frame}; |
549
|
55
|
|
|
|
|
79
|
my $lineNo; # when reading existing array |
550
|
|
|
|
|
|
|
|
551
|
55
|
|
|
|
|
153
|
$code->{FirstLine} = 0; |
552
|
55
|
|
|
|
|
167
|
$code->{Lines} = []; |
553
|
|
|
|
|
|
|
|
554
|
55
|
|
|
|
|
111
|
my $lineCnt = 0; |
555
|
|
|
|
|
|
|
|
556
|
55
|
|
|
|
|
88
|
while(1) { |
557
|
|
|
|
|
|
|
|
558
|
566
|
|
|
|
|
1662
|
my $line = { Txt => $InLine, '#' => $. }; |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
# Quick return if it cannot be a directive line - or one that we recognise |
561
|
|
|
|
|
|
|
# If not generating - skip to next |
562
|
566
|
100
|
66
|
|
|
3583
|
unless($InLine =~ /^($self->{DirStartRE})(\w+)\s*(.*)/ and |
|
|
|
66
|
|
|
|
|
563
|
|
|
|
|
|
|
(defined($ctlDirectives{$2}) or defined($self->{subs}->{$2}))) { |
564
|
219
|
50
|
|
|
|
485
|
push @{$code->{Lines}}, $line unless(defined $frame->{Code}); |
|
219
|
|
|
|
|
450
|
|
565
|
219
|
|
|
|
|
286
|
$lineCnt++; |
566
|
|
|
|
|
|
|
} else { |
567
|
|
|
|
|
|
|
|
568
|
347
|
|
|
|
|
787
|
my $leadin = $1; # String that identified the directive |
569
|
347
|
|
|
|
|
517
|
my $dir = $2; # Directive |
570
|
347
|
|
|
|
|
565
|
my $arg = $3; # Its argument |
571
|
|
|
|
|
|
|
|
572
|
347
|
100
|
|
|
|
728
|
if(exists $loops{$dir}) { |
573
|
|
|
|
|
|
|
# Loop buster: |
574
|
41
|
|
|
|
|
96
|
my $max = $self->{MaxLoopCount}; |
575
|
41
|
100
|
|
|
|
145
|
$max = $1 if($arg =~ s/^-i\s*(\d+)\s*//); |
576
|
41
|
|
|
|
|
156
|
$line->{LoopMax} = $max; |
577
|
|
|
|
|
|
|
|
578
|
|
|
|
|
|
|
# Get loop condition: |
579
|
41
|
50
|
|
|
|
109
|
return $self->SetError("Missing $dir condition at $self->{Place}", 1) unless($arg ne ''); |
580
|
41
|
|
|
|
|
86
|
my $cond = $arg; |
581
|
41
|
|
|
|
|
124
|
$line->{Not} = $dir eq 'until'; |
582
|
|
|
|
|
|
|
|
583
|
41
|
100
|
|
|
|
112
|
if($dir eq 'for') { |
584
|
|
|
|
|
|
|
# Break out, 3 expressions, preserve trailing ones |
585
|
14
|
|
|
|
|
84
|
my @e = split /;;/, $arg, 4; |
586
|
14
|
50
|
|
|
|
52
|
return $self->SetError("Bad for loop, expecting: 'init ;; condition ;; expression' at $self->{Place}", 1) |
587
|
|
|
|
|
|
|
unless(@e == 3); |
588
|
|
|
|
|
|
|
|
589
|
14
|
100
|
|
|
|
83
|
$line->{Init} = $e[0] if($e[0] =~ /\S/); |
590
|
|
|
|
|
|
|
|
591
|
14
|
50
|
|
|
|
64
|
$e[1] = '1' unless($e[1] =~ /\S/); # Set default condition - true |
592
|
14
|
|
|
|
|
38
|
$cond = $e[1]; |
593
|
|
|
|
|
|
|
|
594
|
14
|
100
|
|
|
|
60
|
if($e[2] =~ /\S/) { |
595
|
|
|
|
|
|
|
return $self->SetError("$dir for expression '$e[2]' fails to compile at $self->{Place}", 1) |
596
|
11
|
50
|
|
|
|
55
|
unless($line->{For3} = $self->{Math}->Parse($e[2])); |
597
|
|
|
|
|
|
|
} |
598
|
|
|
|
|
|
|
} |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
# Compile the condition below: |
601
|
41
|
|
|
|
|
2812
|
$cond =~ s/^\s*//; |
602
|
41
|
|
|
|
|
102
|
$arg = $cond; |
603
|
|
|
|
|
|
|
} |
604
|
347
|
100
|
|
|
|
757
|
if(exists $makeExpr{$dir}) { |
605
|
|
|
|
|
|
|
# Precompile expression unless it is a .sub (starts '.'): |
606
|
89
|
100
|
|
|
|
330
|
if(substr($arg, 0, length($self->{DirStart})) eq $self->{DirStart}) { |
607
|
43
|
|
|
|
|
91
|
$line->{SubCond} = $arg; |
608
|
|
|
|
|
|
|
} else { |
609
|
|
|
|
|
|
|
return $self->SetError("$dir condition/expression fails to compile '$arg' at $self->{Place}", 1) |
610
|
46
|
50
|
33
|
|
|
298
|
unless($arg =~ /\S/ and ($line->{Expr} = $self->{Math}->Parse($arg))); |
611
|
|
|
|
|
|
|
} |
612
|
|
|
|
|
|
|
} |
613
|
|
|
|
|
|
|
|
614
|
347
|
100
|
66
|
|
|
17596
|
if(defined($blkPairs{$dir})) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
615
|
|
|
|
|
|
|
# Start of block |
616
|
100
|
|
|
|
|
182
|
push @blocks, {type => $dir, LoopStart => @{$code->{Lines}}+0 }; |
|
100
|
|
|
|
|
412
|
|
617
|
|
|
|
|
|
|
} elsif(defined($blkPairs{$blocks[-1]->{type}}) and $blkPairs{$blocks[-1]->{type}} eq $dir) { |
618
|
|
|
|
|
|
|
# End of block |
619
|
|
|
|
|
|
|
|
620
|
100
|
|
|
|
|
178
|
my $blk = pop @blocks; |
621
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
# Consistency check |
623
|
|
|
|
|
|
|
return $self->SetError("$leadin$dir followed by '$1' but match is '$blk->{type}' at $self->{Place}", 1) |
624
|
100
|
50
|
66
|
|
|
279
|
if($arg =~ /(\S+)/ and $blk->{type} ne $1); |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
# If loop add LoopStart/LoopEnd |
627
|
100
|
100
|
|
|
|
310
|
if(exists $loops{$blk->{type}}) { |
628
|
41
|
|
|
|
|
77
|
my $start = $blk->{LoopStart}; |
629
|
41
|
|
|
|
|
73
|
my $topl = $code->{Lines}->[$start]; |
630
|
41
|
|
|
|
|
91
|
$topl->{LoopStart} = $start; |
631
|
41
|
|
|
|
|
56
|
$topl->{LoopEnd} = @{$code->{Lines}}+1; |
|
41
|
|
|
|
|
160
|
|
632
|
|
|
|
|
|
|
} |
633
|
|
|
|
|
|
|
|
634
|
|
|
|
|
|
|
} elsif(defined($endings{$dir})) { |
635
|
0
|
|
|
|
|
0
|
return $self->SetError("Unexpected $leadin$dir at $self->{Place} in $code->{Block} $started", 1) |
636
|
|
|
|
|
|
|
} |
637
|
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
# Buffer in array |
639
|
347
|
|
|
|
|
594
|
push @{$code->{Lines}}, $line; |
|
347
|
|
|
|
|
696
|
|
640
|
347
|
|
|
|
|
488
|
$lineCnt++; |
641
|
|
|
|
|
|
|
|
642
|
347
|
100
|
100
|
|
|
902
|
last if($dir eq 'done' and @blocks == 0); |
643
|
|
|
|
|
|
|
} |
644
|
|
|
|
|
|
|
|
645
|
|
|
|
|
|
|
# Next line |
646
|
|
|
|
|
|
|
do{ |
647
|
0
|
|
|
|
|
0
|
return $self->SetError("Unexpected EOF at $self->{Place} while reading $code->{Block} $started", 1) |
648
|
511
|
50
|
|
|
|
8555
|
} unless($InLine = $self->{Frame}->{Fd}->getline); |
649
|
|
|
|
|
|
|
|
650
|
511
|
|
|
|
|
12365
|
$self->{Place} = "line $. of $self->{Frame}->{Name}"; |
651
|
|
|
|
|
|
|
} |
652
|
|
|
|
|
|
|
|
653
|
55
|
|
|
|
|
267
|
$code->{LastLine} = $code->{FirstLine} + $lineCnt - 1; |
654
|
|
|
|
|
|
|
} |
655
|
|
|
|
|
|
|
|
656
|
|
|
|
|
|
|
# Run a sub: open a frame, process arguments |
657
|
|
|
|
|
|
|
sub RunSub |
658
|
|
|
|
|
|
|
{ |
659
|
165
|
|
|
165
|
0
|
469
|
my ($self, $dir, $arg) = @_; |
660
|
165
|
|
|
|
|
478
|
my @args = $self->SplitArgs($arg, 1); |
661
|
165
|
|
|
|
|
407
|
my $code = $self->{subs}->{$dir}; # Code read earlier |
662
|
|
|
|
|
|
|
|
663
|
|
|
|
|
|
|
# New frame to run the sub |
664
|
|
|
|
|
|
|
$self->openFrame(Code => $code, Block => $dir, Args => [@args], |
665
|
|
|
|
|
|
|
LineNumber => $code->{FileLine}, Name => $code->{FileName}, |
666
|
165
|
|
|
|
|
944
|
CodeLine => $code->{FirstLine}, ReturnFrom => 1); |
667
|
165
|
|
|
|
|
351
|
my $frame = $self->{Frame}; |
668
|
165
|
|
|
|
|
302
|
delete $frame->{Fd}; |
669
|
|
|
|
|
|
|
|
670
|
|
|
|
|
|
|
# If argument names are supplied, set as local vars: |
671
|
165
|
100
|
66
|
|
|
540
|
if($code->{ArgNames} && @{$code->{ArgNames}}) { |
|
112
|
|
|
|
|
457
|
|
672
|
112
|
|
|
|
|
238
|
my $vh = $self->{Math}->{VarHash}; |
673
|
112
|
|
|
|
|
207
|
foreach my $vname (@{$code->{ArgNames}}) { |
|
112
|
|
|
|
|
338
|
|
674
|
228
|
|
|
|
|
412
|
my $vval = $vh->{$vname}; |
675
|
228
|
|
|
|
|
559
|
$frame->{LocalVars}->{$vname} = $vval; |
676
|
228
|
|
|
|
|
354
|
delete($vh->{$vname}); |
677
|
|
|
|
|
|
|
|
678
|
228
|
100
|
|
|
|
885
|
$vh->{$vname} = [shift @args] if(@args); |
679
|
|
|
|
|
|
|
} |
680
|
|
|
|
|
|
|
} |
681
|
|
|
|
|
|
|
} |
682
|
|
|
|
|
|
|
|
683
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
# Evaluate the condition, return true/false, or undef on error |
685
|
|
|
|
|
|
|
# This could be a Math expression or a .sub returned value |
686
|
|
|
|
|
|
|
# BEWARE: This could open a new frame to set up a sub, return to run it and frame.CondReReun |
687
|
|
|
|
|
|
|
# will make the .if/... return here to see what the .return was. |
688
|
|
|
|
|
|
|
sub EvalCond |
689
|
|
|
|
|
|
|
{ |
690
|
475
|
|
|
475
|
0
|
1337
|
my ($self, $replay, $dir, $place, $arg) = @_; |
691
|
475
|
|
|
|
|
776
|
my ($iftree, $true, $esc); |
692
|
|
|
|
|
|
|
|
693
|
|
|
|
|
|
|
# Is the condition a sub-call/directive ? |
694
|
475
|
100
|
66
|
|
|
2339
|
if(($esc = exists($replay->{SubCond})) or |
|
|
|
100
|
|
|
|
|
695
|
|
|
|
|
|
|
(substr($arg, 0, length($self->{DirStart})) eq $self->{DirStart} and $arg =~ /^$self->{DirStartRE}(\w+)\s*(.*)/)) { |
696
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
# If buffered code (loop/sub) get the arg string and break to subroutine and its arguments: |
698
|
282
|
100
|
|
|
|
1833
|
($arg = $replay->{SubCond}) =~ /^$self->{DirStartRE}(\w+)\s*(.*)/ if($esc); |
699
|
|
|
|
|
|
|
|
700
|
282
|
|
|
|
|
905
|
my ($sub, $args) = ($1, $2); |
701
|
|
|
|
|
|
|
|
702
|
282
|
|
|
|
|
453
|
my $intDir = 0; # If true: $sub is allowed internal directive |
703
|
282
|
100
|
|
|
|
733
|
unless( exists $self->{subs}->{$sub}) { |
704
|
|
|
|
|
|
|
return $self->SetError("Unknown sub '$sub' in $dir at $place", 1) |
705
|
66
|
50
|
|
|
|
165
|
unless exists($condDirectives{$sub}); |
706
|
66
|
|
|
|
|
116
|
$intDir = 1; |
707
|
|
|
|
|
|
|
} |
708
|
|
|
|
|
|
|
|
709
|
282
|
100
|
|
|
|
764
|
unless($self->{Frame}->{CondReRun}) { |
710
|
|
|
|
|
|
|
# First time through: |
711
|
|
|
|
|
|
|
# Set up the sub, return to main loop to run it |
712
|
141
|
|
|
|
|
357
|
$self->{Frame}->{CondReRun} = 10; |
713
|
|
|
|
|
|
|
|
714
|
|
|
|
|
|
|
# Cause the .if/.while/... to be run again. |
715
|
|
|
|
|
|
|
# If buffered back up a line, else push back to input for this frame |
716
|
141
|
100
|
|
|
|
330
|
if($esc) { |
717
|
122
|
|
|
|
|
250
|
$self->{Frame}->{CodeLine}--; |
718
|
|
|
|
|
|
|
} else { |
719
|
19
|
|
|
|
|
30
|
push @{$self->{Frame}->{PushedInput}}, "$self->{DirStart}$dir $arg"; |
|
19
|
|
|
|
|
75
|
|
720
|
|
|
|
|
|
|
} |
721
|
|
|
|
|
|
|
|
722
|
141
|
100
|
|
|
|
378
|
if($intDir) { |
723
|
|
|
|
|
|
|
# Create a frame with just 1 line to run internal command |
724
|
33
|
|
|
|
|
221
|
$self->openFrame(CodeLine => 0, Code => {Lines => [{ Txt => $arg, '#' => 1 }], LastLine => 0 } ); |
725
|
|
|
|
|
|
|
} else { |
726
|
|
|
|
|
|
|
# Run the sub |
727
|
108
|
|
|
|
|
371
|
$self->RunSub($sub, $args); |
728
|
|
|
|
|
|
|
} |
729
|
|
|
|
|
|
|
|
730
|
141
|
|
|
|
|
327
|
$self->{Frame}->{CondReRun} = 1; # Cause return here |
731
|
141
|
|
|
|
|
325
|
$self->{Frame}->{intDir} = $intDir; # Directive or sub ? |
732
|
141
|
|
|
|
|
263
|
$self->{Frame}->{Generate} = 1; # Cause sub/directive to run |
733
|
|
|
|
|
|
|
|
734
|
141
|
|
|
|
|
403
|
return 0; |
735
|
|
|
|
|
|
|
|
736
|
|
|
|
|
|
|
} else { |
737
|
|
|
|
|
|
|
# 2nd time: |
738
|
|
|
|
|
|
|
# Get the command 'exit' code & tidy up: |
739
|
|
|
|
|
|
|
|
740
|
141
|
100
|
|
|
|
363
|
delete $self->{Frame}->{CondReRun} unless($esc); |
741
|
141
|
|
|
|
|
389
|
$true = $self->{Math}->{VarHash}->{_}->[-1]; |
742
|
|
|
|
|
|
|
$self->closeFrame # Close internal command frame |
743
|
141
|
50
|
|
|
|
375
|
if($self->{Frame}->{intDir}); |
744
|
|
|
|
|
|
|
|
745
|
141
|
100
|
|
|
|
470
|
delete $self->{Frame}->{CondReRun} if($esc); |
746
|
|
|
|
|
|
|
} |
747
|
|
|
|
|
|
|
|
748
|
|
|
|
|
|
|
} else { |
749
|
|
|
|
|
|
|
# It is a conventional expression |
750
|
193
|
100
|
66
|
|
|
753
|
if($replay and exists $replay->{Expr}) { |
751
|
158
|
|
|
|
|
289
|
$iftree = $replay->{Expr}; |
752
|
|
|
|
|
|
|
} else { |
753
|
|
|
|
|
|
|
return $self->SetError("Bad $self->{DirStart}$dir expression $place in $self->{Frame}->{Name} '$arg'", 1) |
754
|
35
|
50
|
|
|
|
100
|
unless($iftree = $self->{Math}->Parse($arg)); |
755
|
|
|
|
|
|
|
} |
756
|
|
|
|
|
|
|
|
757
|
193
|
|
|
|
|
6798
|
$true = $self->{Math}->EvalToScalar($iftree); |
758
|
|
|
|
|
|
|
} |
759
|
|
|
|
|
|
|
|
760
|
334
|
100
|
|
|
|
19991
|
$true = ! $true if($replay->{Not}); |
761
|
|
|
|
|
|
|
|
762
|
334
|
|
|
|
|
878
|
$true |
763
|
|
|
|
|
|
|
} |
764
|
|
|
|
|
|
|
|
765
|
|
|
|
|
|
|
|
766
|
|
|
|
|
|
|
|
767
|
|
|
|
|
|
|
# Return true on error |
768
|
|
|
|
|
|
|
sub error |
769
|
|
|
|
|
|
|
{ |
770
|
458
|
|
|
458
|
1
|
724
|
my $self = shift; |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
$self->{Error} or (defined($self->{Frame}) and $self->{Frame}->{Fd} and $self->{Frame}->{Fd}->error) |
773
|
458
|
50
|
66
|
|
|
3203
|
} |
|
|
|
66
|
|
|
|
|
774
|
|
|
|
|
|
|
|
775
|
|
|
|
|
|
|
# As IO::Handle, clear recent error |
776
|
|
|
|
|
|
|
sub clearerr |
777
|
|
|
|
|
|
|
{ |
778
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
779
|
|
|
|
|
|
|
|
780
|
0
|
|
|
|
|
0
|
$self->{Error} = 0; |
781
|
0
|
0
|
0
|
|
|
0
|
return -1 unless $self->{Fd} && $self->{Fd}->opened; |
782
|
|
|
|
|
|
|
|
783
|
|
|
|
|
|
|
$self->{Fd}->clearerr |
784
|
0
|
|
|
|
|
0
|
} |
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
# Record the error at $errstr and maybe $!, note that there has been an error, return undef |
787
|
|
|
|
|
|
|
# Arg is description of the error |
788
|
|
|
|
|
|
|
# Optional extra arg. If true set $! to EINVAL - use this eg where file format error |
789
|
|
|
|
|
|
|
sub SetError |
790
|
|
|
|
|
|
|
{ |
791
|
0
|
|
|
0
|
0
|
0
|
my ($self, $errm, $einval) = @_; |
792
|
|
|
|
|
|
|
|
793
|
0
|
|
|
|
|
0
|
$self->{Error} = 1; |
794
|
0
|
|
|
|
|
0
|
$errstr = $errm; |
795
|
|
|
|
|
|
|
|
796
|
0
|
0
|
|
|
|
0
|
die "$errm\n" if($self->{OnError} eq 'die' ); |
797
|
0
|
0
|
|
|
|
0
|
warn "$errm\n" if($self->{OnError} eq 'warn'); |
798
|
|
|
|
|
|
|
|
799
|
0
|
0
|
|
|
|
0
|
if($einval) { |
800
|
1
|
|
|
1
|
|
357
|
use Errno; |
|
1
|
|
|
|
|
1680
|
|
|
1
|
|
|
|
|
4742
|
|
801
|
0
|
|
|
|
|
0
|
$! = &Errno::EINVAL; |
802
|
|
|
|
|
|
|
} |
803
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
return undef |
805
|
0
|
|
|
|
|
0
|
} |
806
|
|
|
|
|
|
|
|
807
|
|
|
|
|
|
|
# Put line(s) to be read as input |
808
|
|
|
|
|
|
|
sub putline { |
809
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
810
|
|
|
|
|
|
|
|
811
|
0
|
|
|
|
|
0
|
push @{$self->{Frame}->{PushedInput}}, @_ |
|
0
|
|
|
|
|
0
|
|
812
|
|
|
|
|
|
|
} |
813
|
|
|
|
|
|
|
|
814
|
|
|
|
|
|
|
# Wrapper for _getline() |
815
|
|
|
|
|
|
|
# The point is that we might be outputting to a stream rather than returning |
816
|
|
|
|
|
|
|
# a line of input to the program. |
817
|
|
|
|
|
|
|
sub getline { |
818
|
1012
|
|
|
1012
|
1
|
14609
|
my $self = shift; |
819
|
|
|
|
|
|
|
|
820
|
1012
|
|
|
|
|
1494
|
while(1) { |
821
|
1014
|
|
|
|
|
2245
|
my $l = $self->_getline; |
822
|
|
|
|
|
|
|
|
823
|
1014
|
100
|
|
|
|
4627
|
return $l if($self->{out} eq ""); # No stream set, return to caller |
824
|
|
|
|
|
|
|
|
825
|
2
|
|
|
|
|
8
|
$self->writeToStream($self->{out}, $l); |
826
|
|
|
|
|
|
|
} |
827
|
|
|
|
|
|
|
} |
828
|
|
|
|
|
|
|
|
829
|
|
|
|
|
|
|
# Write the argument line $l to the output $stream |
830
|
|
|
|
|
|
|
# It can be an IO::FILE or subroutine |
831
|
|
|
|
|
|
|
sub writeToStream { |
832
|
5
|
|
|
5
|
0
|
11
|
my ($self, $stream, $l) = @_; |
833
|
|
|
|
|
|
|
|
834
|
5
|
|
|
|
|
11
|
my $strm = $self->{OutStreams}->{$stream}; |
835
|
|
|
|
|
|
|
|
836
|
5
|
50
|
|
|
|
11
|
if( !defined($strm)) { |
837
|
|
|
|
|
|
|
# This could result in many messages |
838
|
0
|
|
|
|
|
0
|
$self->SetError("Output stream unknown: '$stream'"); |
839
|
0
|
|
|
|
|
0
|
return; |
840
|
|
|
|
|
|
|
} |
841
|
5
|
100
|
66
|
|
|
29
|
if(ref $strm eq 'IO::File' or ref $strm eq 'IO::Handle') { |
842
|
4
|
|
|
|
|
32
|
print $strm $l; |
843
|
4
|
|
|
|
|
9
|
return; |
844
|
|
|
|
|
|
|
} |
845
|
1
|
50
|
|
|
|
5
|
if(ref $strm eq 'CODE') { |
846
|
1
|
|
|
|
|
7
|
&$strm($l); |
847
|
1
|
|
|
|
|
5
|
return; |
848
|
|
|
|
|
|
|
} |
849
|
|
|
|
|
|
|
# Should not get here |
850
|
0
|
|
|
|
|
0
|
$self->SetError("Output stream '$stream' is not an IO::File or IO::Handle or subroutine, but is: " . ref $strm); |
851
|
|
|
|
|
|
|
} |
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
# Called when every line is read |
854
|
|
|
|
|
|
|
# One problem with this is that it cannot store anything in a local variable |
855
|
|
|
|
|
|
|
# as it returns once it finds a line that it cannot process itself. |
856
|
|
|
|
|
|
|
# Store in the object. |
857
|
|
|
|
|
|
|
# Can't store 'static' since there may be different files open for different purposes. |
858
|
|
|
|
|
|
|
# getline() getlines() close() are deliberately compatible with IO::Handle. new() is not, it is more complicated. |
859
|
|
|
|
|
|
|
sub _getline { |
860
|
1014
|
|
|
1014
|
|
1511
|
my $self = shift; |
861
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
return $self->SetError("A file has not been opened", 1) |
863
|
1014
|
50
|
66
|
|
|
3416
|
unless defined $self->{Frame}->{Code} or defined $self->{Frame}->{Fd}; |
864
|
|
|
|
|
|
|
|
865
|
1014
|
|
|
|
|
1661
|
my $doneDone = 0; # Last directive was .done |
866
|
1014
|
|
|
|
|
1902
|
my $vh = $self->{Math}->{VarHash}; |
867
|
|
|
|
|
|
|
|
868
|
1014
|
|
|
|
|
1296
|
while(1) { |
869
|
|
|
|
|
|
|
|
870
|
|
|
|
|
|
|
return undef |
871
|
3043
|
50
|
|
|
|
6354
|
if $self->{Error}; |
872
|
|
|
|
|
|
|
|
873
|
|
|
|
|
|
|
return undef |
874
|
3043
|
100
|
|
|
|
4020
|
unless(@{$self->{FrameStk}}); |
|
3043
|
|
|
|
|
6596
|
|
875
|
|
|
|
|
|
|
|
876
|
2984
|
|
|
|
|
4342
|
my $lineno; |
877
|
2984
|
|
|
|
|
4515
|
my $frame = $self->{Frame}; |
878
|
2984
|
|
|
|
|
3866
|
my $replay; |
879
|
|
|
|
|
|
|
|
880
|
2984
|
100
|
|
|
|
3651
|
if(defined ($_ = pop @{$frame->{PushedInput}})) { |
|
2984
|
100
|
|
|
|
8808
|
|
881
|
|
|
|
|
|
|
# Line pushed back to input |
882
|
19
|
|
|
|
|
43
|
$lineno = $frame->{LineNumber}; |
883
|
|
|
|
|
|
|
} elsif(exists $frame->{Code}) { |
884
|
|
|
|
|
|
|
# Loop or sub |
885
|
|
|
|
|
|
|
# End of code ? |
886
|
1713
|
100
|
|
|
|
3968
|
if($frame->{CodeLine} > $frame->{Code}->{LastLine}) { |
887
|
83
|
|
|
|
|
254
|
$self->closeFrame; |
888
|
83
|
|
|
|
|
492
|
next; |
889
|
|
|
|
|
|
|
} |
890
|
|
|
|
|
|
|
|
891
|
1630
|
|
|
|
|
3328
|
$replay = $frame->{Code}{Lines}->[$frame->{CodeLine}++]; |
892
|
1630
|
|
|
|
|
2831
|
$_ = $replay->{Txt}; |
893
|
1630
|
|
|
|
|
2502
|
$lineno = $replay->{'#'}; |
894
|
|
|
|
|
|
|
} else { |
895
|
|
|
|
|
|
|
# From file |
896
|
1252
|
|
|
|
|
26304
|
$_ = $frame->{Fd}->getline; |
897
|
|
|
|
|
|
|
|
898
|
|
|
|
|
|
|
# EOF: |
899
|
1252
|
100
|
|
|
|
33138
|
unless($_) { |
900
|
|
|
|
|
|
|
|
901
|
|
|
|
|
|
|
# EOF. Close the file. This may pop another one if there are multiple open files (.include) |
902
|
|
|
|
|
|
|
return undef |
903
|
78
|
50
|
|
|
|
229
|
unless($self->closeFrame); |
904
|
|
|
|
|
|
|
|
905
|
|
|
|
|
|
|
next # There is still a frame to look at |
906
|
78
|
50
|
|
|
|
1275
|
if($self->{Frame}); |
907
|
|
|
|
|
|
|
|
908
|
|
|
|
|
|
|
# EOF. Return undef |
909
|
0
|
|
|
|
|
0
|
return undef; |
910
|
|
|
|
|
|
|
} |
911
|
|
|
|
|
|
|
|
912
|
1174
|
50
|
|
|
|
2548
|
if($self->{Raw}) { |
913
|
0
|
|
|
|
|
0
|
$vh->{_CountGen}->[0]++; |
914
|
0
|
|
|
|
|
0
|
return $_; |
915
|
|
|
|
|
|
|
} |
916
|
|
|
|
|
|
|
|
917
|
1174
|
|
|
|
|
2229
|
$lineno = $.; |
918
|
1174
|
|
|
|
|
2047
|
chomp; |
919
|
|
|
|
|
|
|
} |
920
|
|
|
|
|
|
|
|
921
|
|
|
|
|
|
|
# Store the line number in a silly number of places: |
922
|
2823
|
|
|
|
|
4597
|
$frame->{LineNumber} = $lineno; |
923
|
2823
|
|
|
|
|
6708
|
$vh->{'_LineNumber'} = [$lineno]; # do directly for speed |
924
|
2823
|
|
|
|
|
9057
|
$self->{Math}->Eval($self->{SetLineMath}); |
925
|
|
|
|
|
|
|
|
926
|
|
|
|
|
|
|
# Something that knows where the current line is: |
927
|
2823
|
|
|
|
|
359866
|
my $place = "line $lineno of $frame->{Name}"; |
928
|
2823
|
|
|
|
|
5455
|
$self->{Place} = $place; |
929
|
|
|
|
|
|
|
|
930
|
|
|
|
|
|
|
EVAL_RESTART: # Restart parsing here after a .eval |
931
|
|
|
|
|
|
|
|
932
|
|
|
|
|
|
|
# Ignore comments |
933
|
2867
|
100
|
|
|
|
11701
|
if(/^$self->{DirStartRE}#/) { |
934
|
534
|
50
|
|
|
|
1305
|
warn "$place: $_\n" if($self->{trace}); |
935
|
534
|
|
|
|
|
1027
|
next; |
936
|
|
|
|
|
|
|
} |
937
|
|
|
|
|
|
|
|
938
|
2333
|
50
|
|
|
|
14405
|
s/\s*$// if($self->{Trim}); |
939
|
|
|
|
|
|
|
|
940
|
|
|
|
|
|
|
# Quick return if it cannot be a directive line - or one that we recognise |
941
|
|
|
|
|
|
|
# If not generating - skip to next |
942
|
2333
|
100
|
100
|
|
|
15012
|
unless(/^($self->{DirStartRE})(\w+)\s*(.*)/ and |
|
|
|
100
|
|
|
|
|
943
|
|
|
|
|
|
|
(defined($ctlDirectives{$2}) or defined($self->{subs}->{$2}))) { |
944
|
616
|
100
|
|
|
|
1420
|
unless($frame->{Generate}) { |
945
|
60
|
|
|
|
|
113
|
$vh->{_CountSkip}->[0]++; |
946
|
60
|
|
|
|
|
134
|
next; |
947
|
|
|
|
|
|
|
} |
948
|
|
|
|
|
|
|
|
949
|
556
|
50
|
|
|
|
1221
|
warn "$place: $_\n" if($self->{trace} > 1); |
950
|
|
|
|
|
|
|
|
951
|
556
|
|
|
|
|
1158
|
$vh->{_CountGen}->[0]++; |
952
|
556
|
|
|
|
|
2025
|
return $_ . $/; # Put the line terminator back on |
953
|
|
|
|
|
|
|
} |
954
|
|
|
|
|
|
|
|
955
|
|
|
|
|
|
|
# Must be a directive: |
956
|
1717
|
|
|
|
|
3787
|
my $leadin = $1; # String that identified the directive |
957
|
1717
|
|
|
|
|
2756
|
my $dir = $2; # Directive |
958
|
1717
|
|
|
|
|
3174
|
my $arg = $3; # Its argument |
959
|
|
|
|
|
|
|
|
960
|
1717
|
0
|
33
|
|
|
3764
|
warn "$place: $_\n" if($self->{trace} and $frame->{Generate}); |
961
|
|
|
|
|
|
|
|
962
|
1717
|
|
|
|
|
3320
|
$vh->{_CountDirect}->[0]++; |
963
|
|
|
|
|
|
|
|
964
|
|
|
|
|
|
|
# Process .if/.else/.fi .unless |
965
|
|
|
|
|
|
|
# Because we can have nested if/... we need a stack of how the conditions evaluated |
966
|
1717
|
100
|
100
|
|
|
6167
|
if($dir eq 'if' or $dir eq 'unless') { |
967
|
|
|
|
|
|
|
# start a new frame with .if |
968
|
|
|
|
|
|
|
# Unless we are here a 2nd time as evaluating: .if .subroutine; in which case the frame is already open |
969
|
100
|
100
|
|
|
|
454
|
$self->openFrame( Type => $dir, Else => 0, CpMove => 1) unless($frame->{CondReRun}); |
970
|
100
|
|
|
|
|
204
|
$frame = $self->{Frame}; |
971
|
|
|
|
|
|
|
|
972
|
100
|
|
|
|
|
259
|
$frame->{ParentGenerate} = $frame->{DidGenerate} = $frame->{Generate}; |
973
|
|
|
|
|
|
|
|
974
|
|
|
|
|
|
|
# Don't evaluate the .if if we are not generating, the expression could have side effects |
975
|
|
|
|
|
|
|
# Don't compile it either - faster; but means that we only see errors if we try |
976
|
100
|
50
|
|
|
|
263
|
if($frame->{Generate}) { |
977
|
100
|
|
|
|
|
293
|
$replay->{Not} = $dir eq 'unless'; |
978
|
|
|
|
|
|
|
|
979
|
100
|
|
|
|
|
317
|
my $gen = $self->EvalCond($replay, $dir, $place, $arg); |
980
|
100
|
50
|
|
|
|
229
|
return $gen unless defined $gen; |
981
|
100
|
|
|
|
|
180
|
$frame = $self->{Frame}; |
982
|
100
|
100
|
|
|
|
243
|
next if($frame->{CondReRun}); |
983
|
77
|
|
|
|
|
182
|
$frame->{DidGenerate} = $frame->{Generate} = $gen; |
984
|
|
|
|
|
|
|
} |
985
|
|
|
|
|
|
|
|
986
|
77
|
|
|
|
|
193
|
next; |
987
|
|
|
|
|
|
|
} |
988
|
1617
|
100
|
100
|
|
|
4967
|
if($dir eq 'elseif' or $dir eq 'elsif') { |
989
|
|
|
|
|
|
|
return $self->SetError("${leadin}$dir but an ${leadin}if/${leadin}unless has not been seen, at $place", 1) |
990
|
29
|
50
|
66
|
|
|
98
|
unless($frame->{Type} eq 'if' or $frame->{Type} eq 'unless'); |
991
|
|
|
|
|
|
|
return $self->SetError("Cannot have ${leadin}$dir at $place to ${leadin}if after ${leadin}else at line $frame->{Else}", 1) |
992
|
29
|
50
|
|
|
|
68
|
if($frame->{Else}); |
993
|
|
|
|
|
|
|
|
994
|
|
|
|
|
|
|
# Don't record that we have seen it, related errors always refer to the .if |
995
|
|
|
|
|
|
|
|
996
|
|
|
|
|
|
|
# We do the test only if the .if was false - exactly the same as .else below |
997
|
|
|
|
|
|
|
# Do a test if the .if was false and all parents (enclosing .ifs) are true, set the truth of Generate property. |
998
|
|
|
|
|
|
|
|
999
|
29
|
100
|
66
|
|
|
116
|
if($frame->{ParentGenerate} and !$frame->{DidGenerate}) { |
1000
|
27
|
|
|
|
|
81
|
my $gen = $self->EvalCond($replay, $dir, $place, $arg); |
1001
|
27
|
|
|
|
|
52
|
$frame = $self->{Frame}; |
1002
|
27
|
50
|
|
|
|
67
|
return $gen unless defined $gen; |
1003
|
27
|
|
|
|
|
744
|
$frame = $self->{Frame}; |
1004
|
|
|
|
|
|
|
|
1005
|
27
|
100
|
|
|
|
80
|
next if($frame->{CondReRun}); |
1006
|
15
|
|
|
|
|
30
|
$frame->{DidGenerate} = $frame->{Generate} = $gen; |
1007
|
|
|
|
|
|
|
; } else { |
1008
|
2
|
|
|
|
|
6
|
$frame->{Generate} = 0; # Which it might already be |
1009
|
|
|
|
|
|
|
} |
1010
|
|
|
|
|
|
|
|
1011
|
17
|
|
|
|
|
42
|
next; |
1012
|
|
|
|
|
|
|
} |
1013
|
1588
|
100
|
|
|
|
3110
|
if($dir eq 'else') { |
1014
|
|
|
|
|
|
|
|
1015
|
|
|
|
|
|
|
return $self->SetError("${leadin}else but an ${leadin}if has not been seen, at $place", 1) |
1016
|
41
|
50
|
66
|
|
|
152
|
unless($frame->{Type} eq 'if' or $frame->{Type} eq 'unless'); |
1017
|
|
|
|
|
|
|
return $self->SetError("Another ${leadin}else at $place to ${leadin}if starting line $frame->{FrameStart}, first .else at line $frame->{Else}", 1) |
1018
|
41
|
50
|
|
|
|
94
|
if($frame->{Else}); |
1019
|
|
|
|
|
|
|
|
1020
|
41
|
|
|
|
|
92
|
$frame->{Else} = $lineno; # Note where the .else was |
1021
|
|
|
|
|
|
|
|
1022
|
41
|
100
|
|
|
|
83
|
if($frame->{DidGenerate}) { |
1023
|
26
|
|
|
|
|
47
|
$frame->{Generate} = 0; |
1024
|
|
|
|
|
|
|
} else { |
1025
|
15
|
|
|
|
|
35
|
$frame->{Generate} = $frame->{ParentGenerate}; |
1026
|
|
|
|
|
|
|
} |
1027
|
|
|
|
|
|
|
|
1028
|
41
|
|
|
|
|
89
|
next; |
1029
|
|
|
|
|
|
|
} |
1030
|
1547
|
100
|
|
|
|
2766
|
if($dir eq 'fi') { |
1031
|
|
|
|
|
|
|
return $self->SetError("${leadin}fi but an ${leadin}if has not been seen, $place", 1) |
1032
|
73
|
50
|
66
|
|
|
278
|
unless($frame->{Type} eq 'if' or $frame->{Type} eq 'unless'); |
1033
|
|
|
|
|
|
|
|
1034
|
73
|
|
|
|
|
244
|
$self->closeFrame; |
1035
|
73
|
|
|
|
|
349
|
next; |
1036
|
|
|
|
|
|
|
} |
1037
|
|
|
|
|
|
|
|
1038
|
|
|
|
|
|
|
# None of the rest unless generating: |
1039
|
1474
|
100
|
|
|
|
3073
|
next unless $frame->{Generate}; |
1040
|
|
|
|
|
|
|
|
1041
|
1449
|
100
|
|
|
|
2742
|
if($dir eq 'let') { |
1042
|
151
|
|
|
|
|
245
|
my $iftree; |
1043
|
151
|
100
|
66
|
|
|
519
|
if($replay and exists $replay->{Expr}) { |
1044
|
87
|
|
|
|
|
176
|
$iftree = $replay->{Expr}; |
1045
|
|
|
|
|
|
|
} else { |
1046
|
|
|
|
|
|
|
return $self->SetError("Bad ${leadin}let expression $place '$arg'", 1) |
1047
|
64
|
50
|
|
|
|
204
|
unless($iftree = $self->{Math}->Parse($arg)); |
1048
|
|
|
|
|
|
|
} |
1049
|
151
|
|
|
|
|
34382
|
$self->{Math}->EvalToScalar($iftree); |
1050
|
|
|
|
|
|
|
# Don't care what the result is |
1051
|
|
|
|
|
|
|
|
1052
|
151
|
|
|
|
|
17365
|
next; |
1053
|
|
|
|
|
|
|
} |
1054
|
|
|
|
|
|
|
|
1055
|
|
|
|
|
|
|
# Return a line parsed for escapes |
1056
|
1298
|
100
|
|
|
|
2611
|
if($dir eq 'echo') { |
1057
|
399
|
|
|
|
|
757
|
$vh->{_CountGen}->[0]++; |
1058
|
399
|
|
|
|
|
1189
|
return $self->ProcEscapes($arg) . $/; |
1059
|
|
|
|
|
|
|
} |
1060
|
|
|
|
|
|
|
|
1061
|
|
|
|
|
|
|
# Start of loop |
1062
|
899
|
100
|
|
|
|
2022
|
if(exists $loops{$dir}) { # 'while' 'until' 'for' |
1063
|
|
|
|
|
|
|
# Create a new frame with an indicator that this is a loop frame |
1064
|
|
|
|
|
|
|
# With 'for' execute the initialisation expression and record the loop expression |
1065
|
|
|
|
|
|
|
# For/while/until all look the same (until has a truth invert flag) |
1066
|
|
|
|
|
|
|
# On 'EOF' of the recorded array, detect that it is a loop frame: |
1067
|
|
|
|
|
|
|
# - execute any loop expression |
1068
|
|
|
|
|
|
|
# - evaluate the loop condition; closeFrame on false; reset CodeLine on true |
1069
|
|
|
|
|
|
|
|
1070
|
348
|
|
|
|
|
638
|
my $code; |
1071
|
348
|
|
|
|
|
1140
|
my @args = $self->SplitArgs($arg, 1); |
1072
|
348
|
|
|
|
|
637
|
my $oframe = $frame; |
1073
|
|
|
|
|
|
|
|
1074
|
|
|
|
|
|
|
# First time: |
1075
|
348
|
100
|
100
|
|
|
1428
|
unless($doneDone or $frame->{CondReRun}) { |
1076
|
90
|
|
|
|
|
391
|
$self->openFrame(Block => $dir); |
1077
|
90
|
|
|
|
|
214
|
$frame = $self->{Frame}; |
1078
|
|
|
|
|
|
|
} |
1079
|
|
|
|
|
|
|
|
1080
|
|
|
|
|
|
|
# If reading from a stream grab the loop to an array: |
1081
|
348
|
100
|
|
|
|
938
|
unless(exists $frame->{Code}) { |
1082
|
17
|
50
|
|
|
|
96
|
return $code unless($code = $self->ReadLoop($dir, $_, $arg)); |
1083
|
17
|
|
|
|
|
52
|
$frame->{Code} = $code; |
1084
|
17
|
|
|
|
|
47
|
$frame->{CodeLine} = $code->{FirstLine} + 1; |
1085
|
17
|
|
|
|
|
66
|
delete $frame->{Fd}; |
1086
|
|
|
|
|
|
|
} |
1087
|
|
|
|
|
|
|
|
1088
|
|
|
|
|
|
|
# New loop, initialise it: |
1089
|
348
|
100
|
100
|
|
|
1111
|
unless($doneDone or $frame->{CondReRun}) { |
1090
|
90
|
|
|
|
|
294
|
$replay = $frame->{Code}{Lines}->[$frame->{CodeLine} - 1]; |
1091
|
|
|
|
|
|
|
|
1092
|
90
|
|
|
|
|
251
|
$frame->{LoopMax} = $replay->{LoopMax}; |
1093
|
90
|
|
|
|
|
201
|
$frame->{LoopCnt} = 0; |
1094
|
90
|
|
|
|
|
191
|
$frame->{LoopStart} = $replay->{LoopStart}; |
1095
|
90
|
|
|
|
|
174
|
$frame->{LoopEnd} = $replay->{LoopEnd}; |
1096
|
|
|
|
|
|
|
|
1097
|
|
|
|
|
|
|
# Set CodeLine to Line after end - in parent frame (which might be from stream and ignore it) |
1098
|
90
|
|
|
|
|
207
|
$oframe->{CodeLine} = $frame->{LoopEnd}; |
1099
|
|
|
|
|
|
|
|
1100
|
|
|
|
|
|
|
# Evaluate any loop initialisation |
1101
|
90
|
100
|
|
|
|
330
|
$self->{Math}->ParseToScalar($replay->{Init}) if(exists $replay->{Init}); |
1102
|
|
|
|
|
|
|
} |
1103
|
348
|
|
|
|
|
5416
|
$doneDone = 0; |
1104
|
|
|
|
|
|
|
|
1105
|
|
|
|
|
|
|
# Beware: might be here twice |
1106
|
348
|
100
|
|
|
|
799
|
unless($frame->{CondReRun}) { |
1107
|
|
|
|
|
|
|
# Trap run away loops: |
1108
|
|
|
|
|
|
|
return $self->SetError("Maximum iterations ($frame->{LoopMax}) exceeded at $frame->{FrameStart}", 1) |
1109
|
242
|
50
|
66
|
|
|
1117
|
if($frame->{LoopMax} && ++$frame->{LoopCnt} > $frame->{LoopMax}); |
1110
|
|
|
|
|
|
|
|
1111
|
|
|
|
|
|
|
# evaluation loop expression (not on first time) |
1112
|
242
|
100
|
100
|
|
|
944
|
$self->{Math}->EvalToScalar($replay->{For3}) if(exists $replay->{For3} and $frame->{LoopCnt} != 1); |
1113
|
|
|
|
|
|
|
} |
1114
|
|
|
|
|
|
|
|
1115
|
|
|
|
|
|
|
# Evaluate the loop condition - if true keep looping |
1116
|
348
|
|
|
|
|
5740
|
my $bool = $self->EvalCond($replay, $dir, $place, $arg); |
1117
|
348
|
100
|
|
|
|
1049
|
next if($frame->{CondReRun}); |
1118
|
242
|
100
|
|
|
|
645
|
$self->closeFrame if( !$bool); |
1119
|
|
|
|
|
|
|
|
1120
|
242
|
|
|
|
|
1035
|
next; |
1121
|
|
|
|
|
|
|
} |
1122
|
|
|
|
|
|
|
|
1123
|
|
|
|
|
|
|
# Should only be seen at end of loop - which is buffered |
1124
|
551
|
100
|
|
|
|
1169
|
if($dir eq 'done') { |
1125
|
|
|
|
|
|
|
return $self->SetError("Unexpected '$leadin$dir' at $place", 1) |
1126
|
122
|
50
|
|
|
|
306
|
unless(exists $frame->{LoopMax}); |
1127
|
|
|
|
|
|
|
|
1128
|
|
|
|
|
|
|
# Next to run is loop start: |
1129
|
122
|
|
|
|
|
240
|
$frame->{CodeLine} = $frame->{LoopStart}; |
1130
|
122
|
|
|
|
|
198
|
$doneDone = 1; |
1131
|
122
|
|
|
|
|
303
|
next; |
1132
|
|
|
|
|
|
|
} |
1133
|
|
|
|
|
|
|
|
1134
|
429
|
100
|
66
|
|
|
1434
|
if($dir eq 'break' or $dir eq 'last') { |
1135
|
27
|
|
|
|
|
48
|
my $loops = 1; |
1136
|
27
|
100
|
|
|
|
71
|
$loops = $1 if($arg =~ /\s*(\d+)/); |
1137
|
|
|
|
|
|
|
|
1138
|
|
|
|
|
|
|
# Unwind until we find a LoopEnd, then close that frame |
1139
|
27
|
|
|
|
|
44
|
my $le; |
1140
|
27
|
|
66
|
|
|
45
|
do { |
1141
|
|
|
|
|
|
|
# Can't break out of sub: |
1142
|
|
|
|
|
|
|
return $self->SetError("'$leadin$dir' too many loops at $place", 1) |
1143
|
28
|
50
|
|
|
|
78
|
if(exists $self->{Frame}->{ReturnFrom}); |
1144
|
|
|
|
|
|
|
|
1145
|
28
|
|
|
|
|
55
|
$le = exists $self->{Frame}->{LoopEnd}; |
1146
|
|
|
|
|
|
|
return undef |
1147
|
28
|
50
|
|
|
|
87
|
unless($self->closeFrame); |
1148
|
|
|
|
|
|
|
} until($le and --$loops <= 0); |
1149
|
27
|
|
|
|
|
163
|
next; |
1150
|
|
|
|
|
|
|
} |
1151
|
|
|
|
|
|
|
|
1152
|
402
|
100
|
66
|
|
|
1327
|
if($dir eq 'continue' or $dir eq 'next') { |
1153
|
30
|
|
|
|
|
46
|
my $loops = 1; |
1154
|
30
|
100
|
|
|
|
86
|
$loops = $1 if($arg =~ /\s*(\d+)/); |
1155
|
|
|
|
|
|
|
|
1156
|
|
|
|
|
|
|
# Unwind until we find LoopStart, reset to that |
1157
|
30
|
|
|
|
|
47
|
my $ls; |
1158
|
30
|
|
|
|
|
40
|
while(1) { |
1159
|
|
|
|
|
|
|
return $self->SetError("'$leadin$dir' too many loops at $place", 1) |
1160
|
40
|
50
|
|
|
|
99
|
if(exists $self->{Frame}->{ReturnFrom}); |
1161
|
|
|
|
|
|
|
|
1162
|
40
|
100
|
66
|
|
|
155
|
if(($ls = exists $self->{Frame}->{LoopStart}) && --$loops <= 0) { |
1163
|
30
|
|
|
|
|
67
|
$self->{Frame}->{CodeLine} = $self->{Frame}->{LoopStart}; |
1164
|
30
|
|
|
|
|
52
|
last; |
1165
|
|
|
|
|
|
|
} |
1166
|
|
|
|
|
|
|
|
1167
|
|
|
|
|
|
|
return undef |
1168
|
10
|
50
|
|
|
|
29
|
unless($self->closeFrame); |
1169
|
|
|
|
|
|
|
}; |
1170
|
|
|
|
|
|
|
|
1171
|
30
|
|
|
|
|
48
|
$doneDone = 1; # This is like .done |
1172
|
30
|
|
|
|
|
87
|
next; |
1173
|
|
|
|
|
|
|
} |
1174
|
|
|
|
|
|
|
|
1175
|
|
|
|
|
|
|
# Local variable |
1176
|
372
|
100
|
|
|
|
909
|
if($dir eq 'local') { |
1177
|
|
|
|
|
|
|
# Push to previous var hash for this stack frame |
1178
|
|
|
|
|
|
|
# This will be undone by closeFrame() |
1179
|
16
|
|
|
|
|
71
|
foreach my $vname (split ' ', $arg) { |
1180
|
28
|
|
|
|
|
56
|
my $vval = $vh->{$vname}; |
1181
|
28
|
|
|
|
|
53
|
$frame->{LocalVars}->{$vname} = $vval; |
1182
|
28
|
|
|
|
|
68
|
delete($vh->{$vname}); |
1183
|
|
|
|
|
|
|
} |
1184
|
16
|
|
|
|
|
37
|
next; |
1185
|
|
|
|
|
|
|
} |
1186
|
|
|
|
|
|
|
|
1187
|
|
|
|
|
|
|
# Include another file |
1188
|
356
|
100
|
|
|
|
792
|
if($dir eq 'include') { |
1189
|
42
|
|
|
|
|
109
|
my (@push, @args, $stream, $fd); |
1190
|
42
|
|
|
|
|
99
|
my $level = 0; |
1191
|
|
|
|
|
|
|
|
1192
|
42
|
100
|
|
|
|
200
|
if($arg =~ s/^-s\s*(\w+)\s*//) { |
1193
|
8
|
|
|
|
|
23
|
$stream = $1; |
1194
|
|
|
|
|
|
|
return $self->SetError("Stream '$stream' already open at $place") |
1195
|
8
|
50
|
|
|
|
32
|
if(exists($self->{Streams}->{$stream})); |
1196
|
|
|
|
|
|
|
} |
1197
|
|
|
|
|
|
|
|
1198
|
42
|
50
|
|
|
|
157
|
return undef unless(@args = $self->SplitArgs($arg, 1)); |
1199
|
42
|
50
|
|
|
|
104
|
return $self->SetError("Missing include file at $place") unless(@args); |
1200
|
42
|
|
|
|
|
95
|
my $fn = shift @args; |
1201
|
|
|
|
|
|
|
|
1202
|
|
|
|
|
|
|
# Push the include ? |
1203
|
42
|
100
|
100
|
|
|
191
|
if(!defined($stream) and $fn =~ /^-p(\d*)$/) { |
1204
|
2
|
100
|
|
|
|
8
|
$level = $1 eq '' ? 1 : $1; # Default 1 |
1205
|
|
|
|
|
|
|
|
1206
|
0
|
|
|
|
|
0
|
return $self->SetError("Attempt to push too far (" . (scalar @{$self->{FrameStk}}) . " available) at $place") |
1207
|
2
|
50
|
|
|
|
3
|
if($level > @{$self->{FrameStk}}); |
|
2
|
|
|
|
|
8
|
|
1208
|
2
|
50
|
|
|
|
6
|
return $self->SetError("Missing include file at $place") unless(@args); |
1209
|
2
|
|
|
|
|
5
|
$fn = shift @args; |
1210
|
|
|
|
|
|
|
} |
1211
|
|
|
|
|
|
|
|
1212
|
|
|
|
|
|
|
# Opening a pipe to read from ? |
1213
|
42
|
100
|
|
|
|
137
|
if(substr($fn, 0, 1) eq '|') { |
1214
|
|
|
|
|
|
|
return $self->SetError("Not allowed to open pipe at $place") |
1215
|
12
|
50
|
|
|
|
51
|
unless($self->{PipeOK}); |
1216
|
|
|
|
|
|
|
|
1217
|
|
|
|
|
|
|
# Replace the command if written '|cmd' |
1218
|
12
|
100
|
|
|
|
47
|
$fn = $fn eq '|' ? shift(@args) : substr($fn, 1); |
1219
|
|
|
|
|
|
|
|
1220
|
12
|
|
|
|
|
139
|
$fd = IO::Pipe->new; |
1221
|
12
|
50
|
|
|
|
1201
|
return $self->SetError("Open of pipe '$fn' failed: $! at $place") |
1222
|
|
|
|
|
|
|
unless($fd); |
1223
|
|
|
|
|
|
|
|
1224
|
12
|
|
|
|
|
56
|
$fd->reader($fn, @args); |
1225
|
|
|
|
|
|
|
|
1226
|
12
|
|
|
|
|
28781
|
$fn = "| $fn"; # For messages, etc, only |
1227
|
|
|
|
|
|
|
|
1228
|
12
|
|
|
|
|
74
|
$vh->{_CountOpen}->[0]++; |
1229
|
|
|
|
|
|
|
} else { |
1230
|
30
|
50
|
|
|
|
109
|
return undef unless(defined($fn = $self->ResolveFilename($fn))); |
1231
|
30
|
50
|
|
|
|
101
|
return $self->SetError("Cannot open file '$arg' at $place as $!") |
1232
|
|
|
|
|
|
|
unless($fd = $self->openFile($fn)); |
1233
|
|
|
|
|
|
|
} |
1234
|
|
|
|
|
|
|
|
1235
|
|
|
|
|
|
|
# Either store on a named stream or push to a frame |
1236
|
42
|
100
|
|
|
|
171
|
if(defined($stream)) { |
1237
|
8
|
|
|
|
|
142
|
$self->{Streams}->{$stream} = $fd; |
1238
|
|
|
|
|
|
|
} else { |
1239
|
34
|
|
|
|
|
234
|
$self->openFrame(Name => $fn, Fd => $fd, Args => [@args], Generate => 1, LineNumber => 0, ReturnFrom => 1); |
1240
|
34
|
100
|
|
|
|
112
|
delete $self->{Frame}->{Code} if( !$level); # Back to input from file unless pushed elsewhere |
1241
|
34
|
100
|
|
|
|
96
|
if($level) { |
1242
|
|
|
|
|
|
|
# Insert opened stream/frame down in the stackframes: |
1243
|
2
|
|
|
|
|
13
|
my $str = pop @{$self->{FrameStk}}; |
|
2
|
|
|
|
|
9
|
|
1244
|
2
|
|
|
|
|
10
|
splice @{$self->{FrameStk}}, -$level, 0, $str; |
|
2
|
|
|
|
|
15
|
|
1245
|
|
|
|
|
|
|
} |
1246
|
|
|
|
|
|
|
} |
1247
|
|
|
|
|
|
|
|
1248
|
42
|
|
|
|
|
578
|
next; |
1249
|
|
|
|
|
|
|
} |
1250
|
|
|
|
|
|
|
|
1251
|
|
|
|
|
|
|
# Kill the script with optional exit code |
1252
|
314
|
50
|
|
|
|
731
|
if($dir eq 'exit') { |
1253
|
0
|
|
|
|
|
0
|
my $code = 2; |
1254
|
0
|
0
|
|
|
|
0
|
if($arg ne '') { |
1255
|
0
|
|
|
|
|
0
|
$code = $self->{Math}->ParseToScalar($arg); |
1256
|
0
|
0
|
|
|
|
0
|
unless($code =~ /^\d+$/) { |
1257
|
0
|
|
|
|
|
0
|
print "Exit expression at $place was not numeric: $code\n"; |
1258
|
0
|
|
|
|
|
0
|
$code = 2; |
1259
|
|
|
|
|
|
|
} |
1260
|
|
|
|
|
|
|
} |
1261
|
0
|
|
|
|
|
0
|
exit $code; |
1262
|
|
|
|
|
|
|
} |
1263
|
|
|
|
|
|
|
|
1264
|
|
|
|
|
|
|
# Print a line, -e print to stderr, -o stream write to named stream |
1265
|
|
|
|
|
|
|
# Line parsed for escapes |
1266
|
314
|
100
|
|
|
|
644
|
if($dir eq 'print') { |
1267
|
3
|
|
|
|
|
10
|
my $stream = 'STDOUT'; |
1268
|
3
|
50
|
|
|
|
9
|
$stream = 'STDERR' if($arg =~ s/^-e\b\s*//); |
1269
|
3
|
50
|
|
|
|
17
|
$stream = $1 if($arg =~ s/^-o\s*(\w+)\b\s*//); |
1270
|
|
|
|
|
|
|
|
1271
|
3
|
50
|
|
|
|
11
|
return undef unless(defined($arg = $self->ProcEscapes($arg))); |
1272
|
3
|
|
|
|
|
12
|
$self->writeToStream($stream, "$arg\n"); |
1273
|
3
|
|
|
|
|
6
|
next; |
1274
|
|
|
|
|
|
|
} |
1275
|
|
|
|
|
|
|
|
1276
|
|
|
|
|
|
|
# Set the current output stream |
1277
|
311
|
100
|
|
|
|
742
|
if($dir eq 'out') { |
1278
|
3
|
100
|
|
|
|
23
|
if($arg eq "") { |
|
|
50
|
|
|
|
|
|
1279
|
1
|
|
|
|
|
3
|
$self->{out} = ""; |
1280
|
|
|
|
|
|
|
} elsif($arg =~ s/^(\w+)\s*$//) { |
1281
|
2
|
50
|
|
|
|
7
|
if(defined($self->{OutStreams}->{$1})) { |
1282
|
2
|
|
|
|
|
6
|
$self->{out} = $1; |
1283
|
|
|
|
|
|
|
} else { |
1284
|
0
|
|
|
|
|
0
|
$self->SetError("Unknown output stream '$1'"); |
1285
|
|
|
|
|
|
|
} |
1286
|
|
|
|
|
|
|
} else { |
1287
|
0
|
|
|
|
|
0
|
$self->SetError("Bad or missing stream name '$arg'"); |
1288
|
|
|
|
|
|
|
} |
1289
|
3
|
|
|
|
|
7
|
next; |
1290
|
|
|
|
|
|
|
} |
1291
|
|
|
|
|
|
|
|
1292
|
|
|
|
|
|
|
# Close this file, return to the one that .included it - if any |
1293
|
|
|
|
|
|
|
# This may result in EOF. Check at loop top |
1294
|
308
|
100
|
|
|
|
768
|
if($dir eq 'return') { |
1295
|
|
|
|
|
|
|
# Evaluate expression after .return - in context of the .sub |
1296
|
130
|
|
|
|
|
272
|
my $ret = undef; |
1297
|
130
|
100
|
|
|
|
935
|
$ret = $self->{Math}->ParseToScalar($arg) if($arg =~ /\S/); |
1298
|
130
|
|
|
|
|
22528
|
$vh->{_} = [$ret]; |
1299
|
|
|
|
|
|
|
return undef |
1300
|
130
|
50
|
|
|
|
464
|
unless($self->close); |
1301
|
|
|
|
|
|
|
|
1302
|
130
|
|
|
|
|
1080
|
next; |
1303
|
|
|
|
|
|
|
} |
1304
|
|
|
|
|
|
|
|
1305
|
|
|
|
|
|
|
# Eval: rewrite the line and try again |
1306
|
178
|
100
|
|
|
|
373
|
if($dir eq 'eval') { |
1307
|
44
|
50
|
|
|
|
139
|
return undef unless($_ = $self->ProcEscapes($arg)); |
1308
|
44
|
50
|
|
|
|
233
|
next if(/^$self->{DirStartRE}#/); |
1309
|
44
|
|
|
|
|
110
|
$place = "Evaled: $place"; |
1310
|
44
|
|
|
|
|
232
|
goto EVAL_RESTART; |
1311
|
|
|
|
|
|
|
} |
1312
|
|
|
|
|
|
|
|
1313
|
|
|
|
|
|
|
# Close a named stream |
1314
|
134
|
100
|
|
|
|
308
|
if($dir eq 'close') { |
1315
|
8
|
50
|
|
|
|
83
|
return $self->SetError("Missing option '-n stream' to ${leadin}close at $place", 1) |
1316
|
|
|
|
|
|
|
unless($arg =~ s/^-s\s*(\w+)\s*//); |
1317
|
|
|
|
|
|
|
|
1318
|
8
|
|
|
|
|
37
|
my $stream = $1; |
1319
|
|
|
|
|
|
|
|
1320
|
|
|
|
|
|
|
$self->SetError("Unknown input stream '$stream' in ${leadin}read at $place", 1) |
1321
|
8
|
50
|
|
|
|
42
|
unless(exists($self->{Streams}->{$stream})); |
1322
|
|
|
|
|
|
|
|
1323
|
8
|
|
|
|
|
203
|
delete($self->{Streams}->{$stream}); # Close it |
1324
|
|
|
|
|
|
|
|
1325
|
8
|
|
|
|
|
67
|
next; |
1326
|
|
|
|
|
|
|
} |
1327
|
|
|
|
|
|
|
|
1328
|
|
|
|
|
|
|
# Read next line into var |
1329
|
126
|
100
|
|
|
|
286
|
if($dir eq 'read') { |
1330
|
28
|
|
|
|
|
67
|
my ($stream, $fd); |
1331
|
|
|
|
|
|
|
|
1332
|
28
|
100
|
|
|
|
190
|
$stream = $1 if($arg =~ s/^-s\s*(\w+)\s+//); |
1333
|
|
|
|
|
|
|
|
1334
|
28
|
|
|
|
|
158
|
my ($vname) = $arg =~ /^(\w+)/; |
1335
|
28
|
50
|
|
|
|
93
|
return $self->SetError("Missing argument to ${leadin}read at $place", 1) unless($vname); |
1336
|
|
|
|
|
|
|
|
1337
|
|
|
|
|
|
|
# Find stream or Fd on stack: |
1338
|
28
|
100
|
|
|
|
75
|
if(defined($stream)) { |
1339
|
|
|
|
|
|
|
return $self->SetError("Unknown input stream '$stream' in ${leadin}read at $place", 1) |
1340
|
23
|
50
|
|
|
|
101
|
unless($fd = $self->{Streams}->{$stream}); |
1341
|
|
|
|
|
|
|
} else { |
1342
|
|
|
|
|
|
|
# Find an open file |
1343
|
5
|
|
|
|
|
10
|
my $f = $frame; |
1344
|
5
|
|
|
|
|
14
|
my $i = @{$self->{FrameStk}} - 1; |
|
5
|
|
|
|
|
14
|
|
1345
|
5
|
|
|
|
|
18
|
until(exists($f->{Fd})) { |
1346
|
3
|
|
|
|
|
8
|
$f = $self->{FrameStk}->[--$i]; |
1347
|
|
|
|
|
|
|
} |
1348
|
5
|
|
|
|
|
14
|
$fd = $f->{Fd}; |
1349
|
|
|
|
|
|
|
} |
1350
|
|
|
|
|
|
|
|
1351
|
28
|
|
|
|
|
57
|
my $eof = 1; |
1352
|
28
|
100
|
|
|
|
843
|
if($_ = $fd->getline) { |
1353
|
21
|
|
|
|
|
19960
|
chomp; |
1354
|
21
|
|
|
|
|
49
|
$eof = 0; |
1355
|
21
|
50
|
|
|
|
198
|
s/\s*$// if($self->{Trim}); |
1356
|
|
|
|
|
|
|
} else { |
1357
|
7
|
|
|
|
|
235
|
$_ = ''; |
1358
|
|
|
|
|
|
|
} |
1359
|
|
|
|
|
|
|
|
1360
|
28
|
|
|
|
|
142
|
$vh->{$vname} = [$_]; |
1361
|
28
|
|
|
|
|
107
|
$vh->{'_EOF'} = [0 + $eof]; |
1362
|
28
|
|
|
|
|
85
|
$vh->{'_'} = [1 - $eof]; |
1363
|
28
|
|
|
|
|
89
|
next; |
1364
|
|
|
|
|
|
|
} |
1365
|
|
|
|
|
|
|
|
1366
|
|
|
|
|
|
|
# No operation |
1367
|
98
|
100
|
|
|
|
226
|
next if($dir eq 'noop'); |
1368
|
|
|
|
|
|
|
|
1369
|
|
|
|
|
|
|
# Subroutine definition |
1370
|
97
|
100
|
|
|
|
259
|
if($dir eq 'sub') { |
1371
|
|
|
|
|
|
|
return undef |
1372
|
38
|
50
|
|
|
|
152
|
unless($self->readSub($dir, $_, $arg)); |
1373
|
38
|
|
|
|
|
98
|
next; |
1374
|
|
|
|
|
|
|
} |
1375
|
|
|
|
|
|
|
|
1376
|
59
|
100
|
|
|
|
135
|
if($dir eq 'test') { |
1377
|
2
|
|
|
|
|
12
|
my %an = ('-f' => 2); |
1378
|
2
|
|
|
|
|
10
|
my @args = $self->SplitArgs($arg, 1); |
1379
|
|
|
|
|
|
|
return $self->SetError("'$leadin$dir' bad or missing argument '$arg' at $place", 1) |
1380
|
2
|
50
|
33
|
|
|
21
|
unless(@args and exists($an{$args[0]}) and @args == $an{$args[0]}); |
|
|
|
33
|
|
|
|
|
1381
|
|
|
|
|
|
|
|
1382
|
2
|
50
|
|
|
|
8
|
if($args[0] eq '-f') { |
1383
|
2
|
|
|
|
|
5
|
my ($fn, @stat); |
1384
|
2
|
|
|
|
|
7
|
$vh->{_} = [0]; # assume error |
1385
|
2
|
50
|
33
|
|
|
10
|
if(($fn = $self->ResolveFilename($args[1], 1)) and (@stat = stat $fn)) { |
1386
|
2
|
|
|
|
|
8
|
$vh->{_} = [1]; # OK |
1387
|
2
|
|
|
|
|
12
|
$vh->{_STAT} = [@stat]; |
1388
|
2
|
|
|
|
|
6
|
$vh->{_TestFile} = [$fn]; |
1389
|
|
|
|
|
|
|
} |
1390
|
2
|
|
|
|
|
7
|
next; |
1391
|
|
|
|
|
|
|
} |
1392
|
|
|
|
|
|
|
} |
1393
|
|
|
|
|
|
|
|
1394
|
57
|
50
|
|
|
|
131
|
if($dir eq 'error') { |
1395
|
0
|
0
|
|
|
|
0
|
$arg = "Error at $place" if($arg eq ''); |
1396
|
0
|
|
|
|
|
0
|
return $self->SetError($arg); |
1397
|
|
|
|
|
|
|
} |
1398
|
|
|
|
|
|
|
|
1399
|
57
|
50
|
|
|
|
112
|
if($dir eq 'set') { |
1400
|
|
|
|
|
|
|
return $self->SetError("'$leadin$dir' bad argument '$arg' at $place") |
1401
|
0
|
0
|
0
|
|
|
0
|
unless(($arg =~ /^(\w+)=(\d+)/) and $options{$1}); |
1402
|
0
|
|
|
|
|
0
|
$self->{$1} = $2; |
1403
|
0
|
|
|
|
|
0
|
next; |
1404
|
|
|
|
|
|
|
} |
1405
|
|
|
|
|
|
|
|
1406
|
57
|
50
|
33
|
|
|
388
|
return $self->SetError("Use of reserved directive '$leadin$dir' at $place", 1) |
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
1407
|
|
|
|
|
|
|
if($dir eq 'function' or $dir eq 'do' or $dir eq 'case' or $dir eq 'switch' or $dir eq 'endswitch'); |
1408
|
|
|
|
|
|
|
|
1409
|
|
|
|
|
|
|
# User defined sub. |
1410
|
|
|
|
|
|
|
# At the bottom so cannot redefine an inbuilt directive |
1411
|
57
|
50
|
|
|
|
150
|
if(exists($self->{subs}->{$dir})) { |
1412
|
57
|
|
|
|
|
197
|
$self->RunSub($dir, $arg); |
1413
|
|
|
|
|
|
|
|
1414
|
57
|
|
|
|
|
139
|
next; |
1415
|
|
|
|
|
|
|
} |
1416
|
|
|
|
|
|
|
|
1417
|
|
|
|
|
|
|
# Should not happen |
1418
|
0
|
|
|
|
|
|
return $self->SetError("Unknown directive '$leadin$dir' at $place", 1); |
1419
|
|
|
|
|
|
|
} |
1420
|
|
|
|
|
|
|
} |
1421
|
|
|
|
|
|
|
|
1422
|
|
|
|
|
|
|
# Return the rest of input as an array |
1423
|
|
|
|
|
|
|
sub getlines |
1424
|
|
|
|
|
|
|
{ |
1425
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
1426
|
0
|
|
|
|
|
|
my @lines = (); |
1427
|
|
|
|
|
|
|
|
1428
|
|
|
|
|
|
|
return $self->SetError("A file has not been opened", 1) |
1429
|
0
|
0
|
|
|
|
|
unless $self->{Fd}; |
1430
|
|
|
|
|
|
|
|
1431
|
0
|
0
|
|
|
|
|
return $self->SetError("getlines called in a scalar context", 1) |
1432
|
|
|
|
|
|
|
unless(wantarray); |
1433
|
|
|
|
|
|
|
|
1434
|
0
|
|
|
|
|
|
while(my $line = $self->getline) { |
1435
|
0
|
|
|
|
|
|
push @lines, $line; |
1436
|
|
|
|
|
|
|
} |
1437
|
|
|
|
|
|
|
|
1438
|
|
|
|
|
|
|
@lines |
1439
|
0
|
|
|
|
|
|
} |
1440
|
|
|
|
|
|
|
|
1441
|
|
|
|
|
|
|
# Enable the object to be used in the diamond operator: |
1442
|
1
|
|
|
1
|
|
821
|
use overload '<>' => \&getline, fallback => 1; |
|
1
|
|
|
|
|
729
|
|
|
1
|
|
|
|
|
6
|
|
1443
|
|
|
|
|
|
|
|
1444
|
|
|
|
|
|
|
1; |
1445
|
|
|
|
|
|
|
|
1446
|
|
|
|
|
|
|
__END__ |