File Coverage

blib/lib/IO/ReadPreProcess.pm
Criterion Covered Total %
statement 571 631 90.4
branch 308 436 70.6
condition 94 144 65.2
subroutine 28 34 82.3
pod 10 25 40.0
total 1011 1270 79.6


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__