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

package IO::ReadPreProcess;

# The idea is to provide an 'intelligent' bottom end read function for scripts.
# Read lines, process .if/.else/.fi, do .include .let .print - and more.
# It provides IO::Handle-ish functions to slot in easily to most scripts.

# Author: Alain D D Williams  March 2015, 2016, 2017 Copyright (C) the author.
# SCCS: @(#)ReadPreProcess.pm	1.13 08/03/17 15:16:04

use 5.006;
use strict;
use warnings;
#use Data::Dumper;
use IO::File;
use IO::Pipe;

our $errstr; # Error string

use Math::Expression;

our $VERSION = 0.84;

# Control directive recognised by getline():
my %ctlDirectives = map { $_ => 1 } qw/ break case close continue do done echo else elseif elsif endswitch error eval exit
    fi for if include last let local next noop out print read return set sub switch test unless until while /;

# Directives that can be used in a condition:
my %condDirectives = map { $_ => 1 } qw/ include read test /;

# Need to test for this ... all except first line
my %forbidden = map { $_ => 1 } qw/ function sub /;

# Block pairs: start & ends
my %blkPairs = qw/ sub done while done  until done  for done  if fi  unless fi /;
my %endings = map { $_ => 1 } qw/ done fi /;
my %loops = map { $_ => 1 } qw/ while until for /;
my %makeExpr = map { $_ => 1 } qw/ let if unless elsif elseif while until for /;
my %options = map { $_ => 1 } qw/ trace /;

# Math variables (others see POD below):
# _FileNames - array of open file names
# _LineNumbers  - array of open file names
# _IncludeDepth - how many files open
# _FileName _LineNumber - current ones
# The arrays are to allow the generation of a traceback.

# Properties not described in new
# 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.
#
# Lines contains refs else we would need to update before pushing
sub new
{
    my $class = shift;
    my $self = bless {
	FrameStk =>	[],	# Frames
	Frame =>	undef,	# Reference to current frame (last in FrameStk)

	subs =>		{},	# Keys are known sub
	Streams =>	{},	# Input streams

	out =>		"",	# Name of current output stream, empty string is return line to program

	# Public properties:
	MaxLoopCount =>	50,	# Max times that a loop can go round
	Raw =>		0,	# Return input as it is seen
	PipeOK =>	0,	# True if allowed to open a pipe
	Trim =>		1,	# Trim input lines
	OnError =>	'warn',	# Can set to: warn, die, ''
	OutStreams =>	{},	# Key: name, value: Stream

	Place =>	'??',	# Last read location: current file/line#

	DirStart =>	'.',	# Directive start sequence
	TopIsFd =>	0,	# First file pre-opened, ie Fd passed to open()
	Error =>	0,	# Set true on error, functions then just return undef

        trace =>	0,	# 1 trace directives, 2 trace generated input
	@_
    }, $class;

    # These output streams are given for free:
    $self->{OutStreams}->{STDOUT} = *STDOUT{IO} unless( defined($self->{OutStreams}->{STDOUT}));
    $self->{OutStreams}->{STDERR} = *STDERR{IO} unless( defined($self->{OutStreams}->{STDERR}));

    # Produce an escaped version of the directive start string. All the RE special prefix with a backslash.
    # This will be used at the start of an RE but we want it taken literally.
    unless(defined($self->{DirStartRE})) {
        $self->{DirStartRE} = $self->{DirStart};
        $self->{DirStartRE} =~ s/([\$.()\[\]*+?\\^|])/\\$1/g;
    }
    # This is not worth it:
    # $self->{dirLineRE} = qr/^($self->{DirStartRE})(\w*)\s*(.*)/;
    # $self->{commentRE} = qr/^$self->{DirStartRE}#/;

    $self->{Math} = new Math::Expression(PermitLoops => 1, EnablePrintf => 1)
	unless(defined $self->{Math});

    unless($self->{Math}->{VarHash}->{_Initialised}) {
        $self->{Math}->ParseToScalar('_FileNames := EmptyList; _LineNumbers := EmptyList; _IncludeDepth := 0; _Initialised := 1');
        $self->{Math}->ParseToScalar('_ARGS := (); _ := _EOF := 0');
        $self->{Math}->ParseToScalar('_CountGen := _CountSkip := _CountDirect := _CountFrames := _CountOpen := 0');
    }

    # We do some things a lot - compile them, that is the expensive part:
    my %math = (
    	SetLineMath => '_LineNumbers[-1] := _LineNumber',
        m_openFrame => 'push(_FileNames, _FileName); push(_LineNumbers, _LineNumber); ++_IncludeDepth',
        m_closeFrame => 'pop(_FileNames); pop(_LineNumbers); --_IncludeDepth; _FileName := ""; _LineNumber := 0; if(count(_FileNames)){_FileName := _FileNames[-1]; _LineNumber := _LineNumbers[-1]}',
    );

    while (my($p, $e) = each %math) {
        $self->{$p} = $self->{Math}->Parse($e);
    }

    # Take some out - cause problems if there since we try to set them again
    my %opts;
    for (qw/ Fd File /) {
        if(defined($self->{$_})) {
            $opts{$_} = $self->{$_};
            delete $self->{$_};
        }
    }

    # Attempt to open the file if passed:
    if(defined($opts{File})) {
        if(defined($opts{Fd})) {
            # Already open, note name, push to include stack:
            $self->openFrame(binmode => '', %opts, Name => $opts{File}, LineNumber => 0, Generate => 1, ReturnFrom => 1);
        } else {
            return undef unless($self->open(binmode => '', %opts));
        }
    }

    $self
}

# Open a file. Args:
# * File - a name - mandatory
# * Fd   - a file handle that it is already open on - optional
# Return $self on OK, undef on error
# Pushes the current file on a stack that allows restore by close()
sub open
{
    my $self = shift;
    my %args = @_;

    return $self->SetError('open() must be given File argument', 1)
        if( !defined $args{File});

    # But elsewhere File is called Name - which could be a sub name
    $args{Name} = $args{File};
    delete $args{File};

    # Get it open on $self->{Fd}
    my $Fd;
    if( !defined $args{Fd}) {
        return undef unless($Fd = $self->openFile($args{Name}));
    } else {
        # Use already opened Fd
        $Fd = $args{Fd};
        $self->{TopIsFd} = 1;
    }

    $self->openFrame(%args, Fd => $Fd, LineNumber => 0, Generate => 1, ReturnFrom => 1);
}

# Open a file, apply any binmode, return FD
sub openFile
{
    my ($self, $name) = @_;
    my $Fd;

    return $self->SetError("Open of file '$name' failed: $! at $self->{Place}")
        unless($Fd = IO::File->new($name, 'r'));

    $self->{Math}->{VarHash}->{_CountOpen}->[0]++;

    $Fd->binmode($self->{Frame}->{binmode}) if($self->{Frame}->{binmode});

    $Fd
}

# Internal routine.
# Assign the new values and push onto their own stack so that, after a later open()
# it can be popped by a close() of that later file.
sub openFrame
{
    my $self = shift;
    my %args = @_;
    my $vh = $self->{Math}->{VarHash};

    # Create the new frame:
    my %f = ( PushedInput => [], @_ );

    # Create var _ARGS if argument Args:
    if(defined($args{Args})) {
        $f{LocalVars} = {_ARGS => $vh->{_ARGS}};
        delete $vh->{_ARGS};
        $vh->{_ARGS} = $args{Args};
        delete $f{Args};
    }

    # One of Code or Fd must be passed
    # Must have the following, if not set copy from enclosing frame:
    for my $p (qw/ Code CodeLine Name LineNumber Fd Generate binmode /) {

        $f{$p} = $args{$p} if(defined($args{$p}));

        if(defined($self->{Frame}) && defined($self->{Frame}->{$p})) {
            $f{$p} = $self->{Frame}->{$p} unless(defined($f{$p}));
        }
    }

    $f{FrameStart} = "$f{Name}:$f{LineNumber}";

    push(@{$self->{FrameStk}}, \%f);
    $self->{Frame} = \%f;

    $vh->{_CountFrames}->[0]++;
    $vh->{_LineNumber}->[0] = $f{LineNumber};
    $vh->{_FileName}->[0] = $f{Name};
    $self->{Math}->EvalToScalar($self->{m_openFrame});


    $self; # success
}

# Close a file - this might mean closeing more than 1 frame
# An important block is a (.include) file.
# Check $self->{Fd} for there being an open file.
# Return false on error
sub close
{
    my $self = shift;

    # Unwind until we find a ReturnFrom:
    my $rf;
    do {
        $rf = $self->{Frame}->{ReturnFrom};
        return undef
            unless($self->closeFrame);
    } until($rf);

    $self
}

# Closes the current frame, pops back the previous one - if there was one
sub closeFrame
{
    my $self = shift;

    return $self->SetError("Cannot close when there is not a frame open", 1)
        unless(defined $self->{Frame}->{Code} or defined $self->{Frame}->{Fd});

    # If error: this will be an OS level error
    return $self->SetError("IO::File I/O error: $!")
        if($self->error);

    # Don't close - we don't want to close STDIN, could cause problems
    # Rely on the IO::File object for files that we have opened ourselves being unreferenced and thus closed.
    # $self->{Fd}->close;

    # Pop back the previous state/file - if there was one
    # Pop the description/state for the file just closed and assign
    # state for the file just revealed - what is now at the top of the stack:

    # Pop any local vars:
    if($self->{Frame}->{LocalVars}) {
        my $alist = $self->{Frame}->{LocalVars};
        my $vh = $self->{Math}->{VarHash};
	while (my ($k, undef) = each %$alist) {
            delete($vh->{$k});
            $vh->{$k} = $alist->{$k} if(defined($alist->{$k}));
        }
    }


    my $old = pop(@{$self->{FrameStk}});
    $self->{Frame} = $self->{FrameStk}->[-1];

    $self->{Frame}->{CodeLine} = $old->{CodeLine} if($self->{Frame}->{Code} && $old->{CpMove});

    # Get arith variables in sync
    $self->{Math}->EvalToScalar($self->{m_closeFrame});

    $self
}

# This package is intended to read text files - so straight binmode is prob not wanted.
# But binmode is also used to allow different encoding - eg :utf8
# Return true on success, on error undef with error in $!
# Record the mode in the frame, inherited by child frames
sub binmode
{
    my ($self, $mode) = @_;

    return $self->SetError("binmode: a file has not been opened", 1) unless $self->{Frame}->{Fd};

    $self->{Frame}->{binmode} = $mode;

    $self->{Frame}->{Fd}->binmode($mode);	# Pass the call straight down
}

# Return 1 if the next read will return EOF or the file is not open:
sub eof
{
    my $self = shift;
    return 1 unless($self->{Fd});
    $self->{Fd}->eof;
}

# Get the name of the file to open
# Args:
# * name
# * just return undef if cannot open, don't print error - optional
# First process escapes
# If it starts '$', the next word is a variable, use the value(s) like $PATH - search
# Else resolve
sub ResolveFilename
{
    my ($self, $name, $noerr) = @_;

    # If it starts '$'
    if(substr($name, 0, 1) eq '$') {
        return $self->SetError("Bad syntax include file name: '$name' at $self->{Place}", 1)
            unless($name =~ m:^\$(\w+)(/.+)$:i);
        my ($var, $rest) = ($1, $2);

        my ($pt, @val);
        return $self->SetError("Bad expression in include: '$name' at $self->{Place}", 1)
            unless(($pt = $self->{Math}->Parse($var)) && (@val = $self->{Math}->Eval($pt)));

	# Search down path:
        for my $pref (@val) {
            my $fp = $self->GetPath("$pref$rest");
            return undef unless $fp;
            return $fp # Grab it if it exists
                if(-e $fp);
        }

        return undef if($noerr);

        return $self->SetError("Cannot find a file in search '$name'. $var='@val' at $self->{Place}", 1)
    }

    # Plain file name:
    return $self->GetPath($name);
}

# If it is absolute (starts '/'): accept
# If it starts '#' it is relative to the process's CWD, remove '#' & accept
# The rest are relative to the current file name: prepend any directory name
# Don't try to canonicalise a/b/../c to a/c - think symlinks.
sub GetPath
{
    my ($self, $name) = @_;

    # Absolute path:
    return $name if index($name, '/') == 0;

    # Relative to our CWD:
    if(substr($name, 0, 1) eq '#') {
        $name = substr($name, 1);    # Remove #
        $name = substr($name, 1)     # Remove / after #
            while(substr($name, 0, 1) eq '/');
        return $name;
    }

    # Everything else is relative to the current file

    # Cannot have a relative name if the current file was passed as Fd
    return $self->SetError("Cannot include file relative to file descriptor. '$name' at $self->{Place}", 1)
        if($self->{TopIsFd} && @{$self->{FrameStk}} == 1);
    # **** This refers to self->file - on stack & called Name

    # Find the last opened file name
    my $last;
    return undef
        unless($last = $self->GetLastFileName);

    # Note RE ensures that $currDir is '' if $last does not contain '/':
    my ($currDir) = $last =~ m:^(.*?/?)[^/]+$:;

    $currDir . $name
}

# Get the name of the last file opened, dig down the stack
sub GetLastFileName
{
    my ($self) = @_;

    my $frames = @{$self->{FrameStk}};

    while(--$frames >= 0) {
        return $self->{FrameStk}->[$frames]->{Name} if(exists($self->{FrameStk}->[$frames]->{Fd}));
    }

    return $self->SetError("Cannot find previous file name at $self->{Place}", 1);
}

# Line parsed for escapes: \0 \e \v{varname}. varname is: /\w+/i
# Arg is a string that is processed & returned
sub ProcEscapes
{
    my ($self, $arg) = @_;

    my $ret = '';

    while($arg =~ s/^([^\\]*)\\(.)//) {
        $ret .= $1;
        if($2 eq '0') {
            ; # nothing
        } elsif($2 eq 'e') {
            $ret .= '\\';
        } elsif($2 eq 'v') {
            return $self->SetError("Invalid escape \\v$arg at $self->{Place}", 1)
                unless($arg =~ s/^{(\w+|\w+\[\w+\])}//i);
            my $vn = $1;
            my $vv = $self->{Math}->ParseToScalar($1);
            return $self->SetError("Invalid variable in \\v{$1} at $self->{Place}", 1)
                unless(defined($vv));
            $ret .= $vv;
        } else {
            return $self->SetError("Invalid escape \\$2 at $self->{Place}", 1);
        }
    }
    return $self->SetError("Trailing \\ on line at $self->{Place}", 1)
        if($arg =~ /\\/);

    $ret . $arg;
}

# Split the argument string on spaces into an array of strings.
# If a portion starts with a quote, it may contain a space
# If $doEsc each result is processed by ProcEscapes()
# Return the result or false
sub SplitArgs
{
    my ($self, $arg, $doEsc) = @_;
    my @args = ();

    $arg =~ s/^\s*//;
    while($arg ne '') {
        my $c1 = substr($arg, 0, 1);
        if($c1 eq '"' or $c1 eq "'") {
            # Extract the string delimited by quotes
            return $self->SetError("Bad quoted string at $self->{Place}", 1)
                unless($arg =~ s/^(["'])((\\{2})*|(.*?[^\\](\\{2})*))\1\s*//);
            my $m = $2;
            $m =~ s/\\([\\'"])/$1/g;    # Remove embedded escapes, eg: \" => "
            push(@args, $m);
        } else {
            $arg =~ s/^(\S+)\s*//;
            push(@args, $1);
        }

    }

    @args = map { $self->ProcEscapes($_) } @args if($doEsc);

    @args
}

# Read & store a sub or function to hash in $self->{subs}->{Name}
# Don't start a frame since we are just reading this in
# Return true if OK
sub readSub
{
    my ($self, $direc, $InLine, $arg) = @_;

# Check that $self->{Frame}->{Fd} is an open file

    my $code = { };

    my @args;

    return $self->SetError("Missing $direc name at $self->{Place}", 1) unless($arg ne '');

    # Also need to check that name & args are IDs
    return undef unless(@args = $self->SplitArgs($arg, 0));

    # First is the name:
    $code->{Name} = shift @args;
    return $self->SetError("Error: bad sub name '$code->{Name}' at $self->{Place}")
        unless($code->{Name} =~ /^\w+$/);

    return $self->SetError("Error: Redefinition of sub '$code->{Name}' at $self->{Place}")
        if(exists($self->{subs}->{$code->{Name}}));

    $self->{subs}->{$code->{Name}} = $code;
    $code->{ArgNames} = @args;

    # sub args can have names:
    $code->{ArgNames} = \@args if(@args);

    $code->{Block} = $direc;    # Info only

    $self->ReadBlock($InLine, $code);

    $code->{LastLine}--;	# Remove .done
    $code->{FirstLine}++;	# Remove .sub

    1
}

# $direct is while/until/for
# $arg is loop condition/rest-of-line
# May start: -innn to specify max iterations
# **** THINKS ****
# Loops are found in 2 ways:
# (1) Reading from a {Fd} - ie in getline()
# (2) When in a sub or an enclosing loop
# We always buffer a loop, so the only difference is where/how it is found
# The purpose of this sub is for case (1), need to initiate a buffer creation
# If (1) read into a buffer/code and return a ref to the code
# If (2) set up $code and return that
sub ReadLoop
{
    my ($self, $direc, $InLine, $arg) = @_;

    my $frame = $self->{Frame};

    my $code = { Block => $direc };

    $self->ReadBlock($InLine, $code);

    $code
}

# Read a block (sub or loop) to arg \%code
# If this finds a loop - note it as within what we read -- works for sub & nested loops
# $InLine is the line just read
sub ReadBlock
{
    my ($self, $InLine, $code) = @_;

    # Record where this was found:
    my $h={ FileName => $self->{Frame}->{Name}, FileLine => $self->{Frame}->{LineNumber}};
    while (my($k,$v)= (each %$h)){
        $code->{$k} = $v;
    }

    $code->{start} = "$code->{FileName}:$code->{FileLine}";

    my $started = "started $code->{start}";
    my @blocks;

    my $frame = $self->{Frame};
    my $lineNo;    # when reading existing array

    $code->{FirstLine} = 0;
    $code->{Lines} = [];

    my $lineCnt = 0;

    while(1) {

        my $line = { Txt => $InLine, '#' => $. };

	# Quick return if it cannot be a directive line - or one that we recognise
        # If not generating - skip to next
        unless($InLine =~ /^($self->{DirStartRE})(\w+)\s*(.*)/ and
              (defined($ctlDirectives{$2}) or defined($self->{subs}->{$2}))) {
            push @{$code->{Lines}}, $line unless(defined $frame->{Code});
            $lineCnt++;
         } else {

            my $leadin = $1; # String that identified the directive
            my $dir = $2;    # Directive
            my $arg = $3;    # Its argument

            if(exists $loops{$dir}) {
		# Loop buster:
		my $max = $self->{MaxLoopCount};
		$max = $1 if($arg =~ s/^-i\s*(\d+)\s*//);
                $line->{LoopMax} = $max;

                # Get loop condition:
		return $self->SetError("Missing $dir condition at $self->{Place}", 1) unless($arg ne '');
                my $cond = $arg;
                $line->{Not} = $dir eq 'until';

                if($dir eq 'for') {
                    # Break out, 3 expressions, preserve trailing ones
                    my @e = split /;;/, $arg, 4;
                    return $self->SetError("Bad for loop, expecting: 'init ;; condition ;; expression' at $self->{Place}", 1)
                        unless(@e == 3);

                    $line->{Init} = $e[0] if($e[0] =~ /\S/);

                    $e[1] = '1' unless($e[1] =~ /\S/);    # Set default condition - true
                    $cond = $e[1];

                    if($e[2] =~ /\S/) {
                        return $self->SetError("$dir for expression '$e[2]' fails to compile at $self->{Place}", 1)
                            unless($line->{For3} = $self->{Math}->Parse($e[2]));
                    }
                }

                # Compile the condition below:
                $cond =~ s/^\s*//;
                $arg = $cond;
            }
            if(exists $makeExpr{$dir}) {
                # Precompile expression unless it is a .sub (starts '.'):
                if(substr($arg, 0, length($self->{DirStart})) eq $self->{DirStart}) {
                    $line->{SubCond} = $arg;
                } else {
		    return $self->SetError("$dir condition/expression fails to compile '$arg' at $self->{Place}", 1)
                        unless($arg =~ /\S/ and ($line->{Expr} = $self->{Math}->Parse($arg)));
                }
            }

            if(defined($blkPairs{$dir})) {
                # Start of block
                push @blocks, {type => $dir, LoopStart => @{$code->{Lines}}+0 };
            } elsif(defined($blkPairs{$blocks[-1]->{type}}) and $blkPairs{$blocks[-1]->{type}} eq $dir) {
                # End of block

                my $blk = pop @blocks;

                # Consistency check
                return $self->SetError("$leadin$dir followed by '$1' but match is '$blk->{type}' at $self->{Place}", 1)
                    if($arg =~ /(\S+)/ and $blk->{type} ne $1);

                # If loop add LoopStart/LoopEnd
                if(exists $loops{$blk->{type}}) {
                    my $start = $blk->{LoopStart};
                    my $topl = $code->{Lines}->[$start];
                    $topl->{LoopStart} = $start;
                    $topl->{LoopEnd} = @{$code->{Lines}}+1;
                }

            } elsif(defined($endings{$dir})) {
                return $self->SetError("Unexpected $leadin$dir at $self->{Place} in $code->{Block} $started", 1)
            }

            # Buffer in array
            push @{$code->{Lines}}, $line;
            $lineCnt++;

            last if($dir eq 'done' and @blocks == 0);
        }

        # Next line
        do{
            return $self->SetError("Unexpected EOF at $self->{Place} while reading $code->{Block} $started", 1)
        } unless($InLine = $self->{Frame}->{Fd}->getline);

        $self->{Place} = "line $. of $self->{Frame}->{Name}";
    }

    $code->{LastLine} = $code->{FirstLine} + $lineCnt - 1;
}

# Run a sub: open a frame, process arguments
sub RunSub
{
    my ($self, $dir, $arg) = @_;
    my @args = $self->SplitArgs($arg, 1);
    my $code = $self->{subs}->{$dir}; # Code read earlier

    # New frame to run the sub
    $self->openFrame(Code => $code, Block => $dir, Args => [@args],
        LineNumber => $code->{FileLine}, Name => $code->{FileName},
        CodeLine => $code->{FirstLine}, ReturnFrom => 1);
    my $frame = $self->{Frame};
    delete $frame->{Fd};

    # If argument names are supplied, set as local vars:
    if($code->{ArgNames} && @{$code->{ArgNames}}) {
        my $vh = $self->{Math}->{VarHash};
        foreach my $vname (@{$code->{ArgNames}}) {
            my $vval = $vh->{$vname};
            $frame->{LocalVars}->{$vname} = $vval;
            delete($vh->{$vname});

            $vh->{$vname} = [shift @args] if(@args);
        }
    }
}


# Evaluate the condition, return true/false, or undef on error
# This could be a Math expression or a .sub returned value
# BEWARE: This could open a new frame to set up a sub, return to run it and frame.CondReReun
# will make the .if/... return here to see what the .return was.
sub EvalCond
{
    my ($self, $replay, $dir, $place, $arg) = @_;
    my ($iftree, $true, $esc);

    # Is the condition a sub-call/directive ?
    if(($esc = exists($replay->{SubCond})) or
       (substr($arg, 0, length($self->{DirStart})) eq $self->{DirStart} and $arg =~ /^$self->{DirStartRE}(\w+)\s*(.*)/)) {

	# If buffered code (loop/sub) get the arg string and break to subroutine and its arguments:
        ($arg = $replay->{SubCond}) =~ /^$self->{DirStartRE}(\w+)\s*(.*)/ if($esc);

        my ($sub, $args) = ($1, $2);

        my $intDir = 0; # If true: $sub is allowed internal directive
        unless( exists $self->{subs}->{$sub}) {
            return $self->SetError("Unknown sub '$sub' in $dir at $place", 1)
                unless exists($condDirectives{$sub});
            $intDir = 1;
        }

        unless($self->{Frame}->{CondReRun}) {
            # First time through:
            # Set up the sub, return to main loop to run it
            $self->{Frame}->{CondReRun} = 10;

	    # Cause the .if/.while/... to be run again.
            # If buffered back up a line, else push back to input for this frame
            if($esc) {
                $self->{Frame}->{CodeLine}--;
            } else {
		push @{$self->{Frame}->{PushedInput}}, "$self->{DirStart}$dir $arg";
            }

	    if($intDir) {
                # Create a frame with just 1 line to run internal command
                $self->openFrame(CodeLine => 0, Code => {Lines => [{ Txt => $arg, '#' => 1 }], LastLine => 0 } );
            } else {
                # Run the sub
                $self->RunSub($sub, $args);
            }

            $self->{Frame}->{CondReRun} = 1;	# Cause return here
            $self->{Frame}->{intDir} = $intDir;	# Directive or sub ?
            $self->{Frame}->{Generate} = 1;	# Cause sub/directive to run

            return 0;

        } else {
            # 2nd time:
            # Get the command 'exit' code & tidy up:

            delete $self->{Frame}->{CondReRun} unless($esc);
            $true = $self->{Math}->{VarHash}->{_}->[-1];
            $self->closeFrame  # Close internal command frame
                if($self->{Frame}->{intDir});

	    delete $self->{Frame}->{CondReRun} if($esc);
        }

    } else {
        # It is a conventional expression
        if($replay and exists $replay->{Expr}) {
            $iftree = $replay->{Expr};
        } else {
            return $self->SetError("Bad $self->{DirStart}$dir expression $place in $self->{Frame}->{Name} '$arg'", 1)
                unless($iftree = $self->{Math}->Parse($arg));
        }

        $true = $self->{Math}->EvalToScalar($iftree);
    }

    $true = ! $true if($replay->{Not});

    $true
}



# Return true on error
sub error
{
    my $self = shift;

    $self->{Error} or (defined($self->{Frame}) and $self->{Frame}->{Fd} and $self->{Frame}->{Fd}->error)
}

# As IO::Handle, clear recent error
sub clearerr
{
    my $self = shift;

    $self->{Error} = 0;
    return -1 unless $self->{Fd} && $self->{Fd}->opened;

    $self->{Fd}->clearerr
}

# Record the error at $errstr and maybe $!, note that there has been an error, return undef
# Arg is description of the error
# Optional extra arg. If true set $! to EINVAL - use this eg where file format error
sub SetError
{
    my ($self, $errm, $einval) = @_;

    $self->{Error} = 1;
    $errstr = $errm;

    die  "$errm\n" if($self->{OnError} eq 'die' );
    warn "$errm\n" if($self->{OnError} eq 'warn');

    if($einval) {
        use Errno;
        $! = &Errno::EINVAL;
    }

    return undef
}

# Put line(s) to be read as input
sub putline {
    my $self = shift;

    push @{$self->{Frame}->{PushedInput}}, @_
}

# Wrapper for _getline()
# The point is that we might be outputting to a stream rather than returning
# a line of input to the program.
sub getline {
    my $self = shift;

    while(1) {
        my $l = $self->_getline;

        return $l if($self->{out} eq "");    # No stream set, return to caller

        $self->writeToStream($self->{out}, $l);
    }
}

# Write the argument line $l to the output $stream
# It can be an IO::FILE or subroutine
sub writeToStream {
    my ($self, $stream, $l) = @_;

    my $strm = $self->{OutStreams}->{$stream};

    if( !defined($strm)) {
        # This could result in many messages
        $self->SetError("Output stream unknown: '$stream'");
        return;
    }
    if(ref $strm eq 'IO::File' or ref $strm eq 'IO::Handle') {
        print $strm $l;
        return;
    }
    if(ref $strm eq 'CODE') {
        &$strm($l);
        return;
    }
    # Should not get here
    $self->SetError("Output stream '$stream' is not an IO::File or IO::Handle or subroutine, but is: " . ref $strm);
}

# Called when every line is read
# One problem with this is that it cannot store anything in a local variable
# as it returns once it finds a line that it cannot process itself.
# Store in the object.
# Can't store 'static' since there may be different files open for different purposes.
# getline() getlines() close() are deliberately compatible with IO::Handle. new() is not, it is more complicated.
sub _getline {
    my $self = shift;

    return $self->SetError("A file has not been opened", 1)
        unless defined $self->{Frame}->{Code} or defined $self->{Frame}->{Fd};

    my $doneDone = 0;    # Last directive was .done
    my $vh = $self->{Math}->{VarHash};

    while(1) {

        return undef
            if $self->{Error};

        return undef
            unless(@{$self->{FrameStk}});

        my $lineno;
        my $frame = $self->{Frame};
        my $replay;

	if(defined ($_ = pop @{$frame->{PushedInput}})) {
            # Line pushed back to input
            $lineno = $frame->{LineNumber};
        } elsif(exists $frame->{Code}) {
            # Loop or sub
            # End of code ?
            if($frame->{CodeLine} > $frame->{Code}->{LastLine}) {
                $self->closeFrame;
                next;
            }

            $replay = $frame->{Code}{Lines}->[$frame->{CodeLine}++];
            $_ = $replay->{Txt};
            $lineno = $replay->{'#'};
        } else {
            # From file
            $_ = $frame->{Fd}->getline;

            # EOF:
            unless($_) {

                # EOF. Close the file. This may pop another one if there are multiple open files (.include)
                return undef
                    unless($self->closeFrame);

                next    # There is still a frame to look at
                    if($self->{Frame});

                # EOF. Return undef
                return undef;
            }

            if($self->{Raw}) {
                $vh->{_CountGen}->[0]++;
                return $_;
            }

            $lineno = $.;
            chomp;
        }

        # Store the line number in a silly number of places:
        $frame->{LineNumber} = $lineno;
        $vh->{'_LineNumber'} = [$lineno]; # do directly for speed
	$self->{Math}->Eval($self->{SetLineMath});

	# Something that knows where the current line is:
	my $place = "line $lineno of $frame->{Name}";
	$self->{Place} = $place;

EVAL_RESTART:	# Restart parsing here after a .eval

        # Ignore comments
        if(/^$self->{DirStartRE}#/) {
            warn "$place: $_\n" if($self->{trace});
	    next;
        }

        s/\s*$// if($self->{Trim});

	# Quick return if it cannot be a directive line - or one that we recognise
        # If not generating - skip to next
        unless(/^($self->{DirStartRE})(\w+)\s*(.*)/ and
              (defined($ctlDirectives{$2}) or defined($self->{subs}->{$2}))) {
	    unless($frame->{Generate}) {
                $vh->{_CountSkip}->[0]++;
                next;
            }

            warn "$place: $_\n" if($self->{trace} > 1);

	    $vh->{_CountGen}->[0]++;
            return $_ . $/;	# Put the line terminator back on
        }

	# Must be a directive:
        my $leadin = $1; # String that identified the directive
        my $dir = $2;    # Directive
        my $arg = $3;    # Its argument

        warn "$place: $_\n" if($self->{trace} and $frame->{Generate});

        $vh->{_CountDirect}->[0]++;

        # Process .if/.else/.fi .unless
        # Because we can have nested if/... we need a stack of how the conditions evaluated
        if($dir eq 'if' or $dir eq 'unless') {
            # start a new frame with .if
            # Unless we are here a 2nd time as evaluating: .if .subroutine; in which case the frame is already open
            $self->openFrame( Type => $dir, Else => 0, CpMove => 1) unless($frame->{CondReRun});
            $frame = $self->{Frame};

            $frame->{ParentGenerate} = $frame->{DidGenerate} = $frame->{Generate};

            # Don't evaluate the .if if we are not generating, the expression could have side effects
            # Don't compile it either - faster; but means that we only see errors if we try
            if($frame->{Generate}) {
                $replay->{Not} = $dir eq 'unless';

		my $gen = $self->EvalCond($replay, $dir, $place, $arg);
                return $gen unless defined $gen;
                $frame = $self->{Frame};
                next if($frame->{CondReRun});
                $frame->{DidGenerate} = $frame->{Generate} = $gen;
            }

            next;
        }
        if($dir eq 'elseif' or $dir eq 'elsif') {
            return $self->SetError("${leadin}$dir but an ${leadin}if/${leadin}unless has not been seen, at $place", 1)
                unless($frame->{Type} eq 'if' or $frame->{Type} eq 'unless');
            return $self->SetError("Cannot have ${leadin}$dir at $place to ${leadin}if after ${leadin}else at line $frame->{Else}", 1)
                if($frame->{Else});

	    # Don't record that we have seen it, related errors always refer to the .if

            # We do the test only if the .if was false - exactly the same as .else below
            # Do a test if the .if was false and all parents (enclosing .ifs) are true, set the truth of Generate property.

            if($frame->{ParentGenerate} and !$frame->{DidGenerate}) {
 		my $gen = $self->EvalCond($replay, $dir, $place, $arg);
                $frame = $self->{Frame};
                return $gen unless defined $gen;
                $frame = $self->{Frame};

                next if($frame->{CondReRun});
                $frame->{DidGenerate} = $frame->{Generate} = $gen;
;            } else {
               $frame->{Generate} = 0; # Which it might already be
            }

            next;
        }
        if($dir eq 'else') {

            return $self->SetError("${leadin}else but an ${leadin}if has not been seen, at $place", 1)
                unless($frame->{Type} eq 'if' or $frame->{Type} eq 'unless');
            return $self->SetError("Another ${leadin}else at $place to ${leadin}if starting line $frame->{FrameStart}, first .else at line $frame->{Else}", 1)
                if($frame->{Else});

	    $frame->{Else} = $lineno;    # Note where the .else was

            if($frame->{DidGenerate}) {
                $frame->{Generate} = 0;
            } else {
                $frame->{Generate} = $frame->{ParentGenerate};
            }

            next;
        }
        if($dir eq 'fi') {
            return $self->SetError("${leadin}fi but an ${leadin}if has not been seen, $place", 1)
                unless($frame->{Type} eq 'if' or $frame->{Type} eq 'unless');

	    $self->closeFrame;
            next;
        }

	# None of the rest unless generating:
        next unless $frame->{Generate};

        if($dir eq 'let') {
            my $iftree;
            if($replay and exists $replay->{Expr}) {
                $iftree = $replay->{Expr};
            } else {
                return $self->SetError("Bad ${leadin}let expression $place '$arg'", 1)
                    unless($iftree = $self->{Math}->Parse($arg));
            }
            $self->{Math}->EvalToScalar($iftree);
            # Don't care what the result is

            next;
        }

        # Return a line parsed for escapes
        if($dir eq 'echo') {
            $vh->{_CountGen}->[0]++;
            return $self->ProcEscapes($arg) . $/;
        }

        # Start of loop
        if(exists $loops{$dir}) { # 'while' 'until' 'for'
            # Create a new frame with an indicator that this is a loop frame
            # With 'for' execute the initialisation expression and record the loop expression
            # For/while/until all look the same (until has a truth invert flag)
            # On 'EOF' of the recorded array, detect that it is a loop frame:
            # - execute any loop expression
            # - evaluate the loop condition; closeFrame on false; reset CodeLine on true

            my $code;
            my @args = $self->SplitArgs($arg, 1);
            my $oframe = $frame;

	    # First time:
            unless($doneDone or $frame->{CondReRun}) {
                $self->openFrame(Block => $dir);
                $frame = $self->{Frame};
            }

            # If reading from a stream grab the loop to an array:
            unless(exists $frame->{Code}) {
                return $code unless($code = $self->ReadLoop($dir, $_, $arg));
                $frame->{Code} = $code;
                $frame->{CodeLine} = $code->{FirstLine} + 1;
                delete $frame->{Fd};
            }

            # New loop, initialise it:
            unless($doneDone or $frame->{CondReRun}) {
		$replay = $frame->{Code}{Lines}->[$frame->{CodeLine} - 1];

		$frame->{LoopMax} = $replay->{LoopMax};
                $frame->{LoopCnt} = 0;
                $frame->{LoopStart} = $replay->{LoopStart};
                $frame->{LoopEnd} = $replay->{LoopEnd};

		# Set CodeLine to Line after end - in parent frame (which might be from stream and ignore it)
		$oframe->{CodeLine} = $frame->{LoopEnd};

                # Evaluate any loop initialisation
                $self->{Math}->ParseToScalar($replay->{Init}) if(exists $replay->{Init});
            }
            $doneDone = 0;

	    # Beware: might be here twice
	    unless($frame->{CondReRun}) {
	    	# Trap run away loops:
            	return $self->SetError("Maximum iterations ($frame->{LoopMax}) exceeded at $frame->{FrameStart}", 1)
                    if($frame->{LoopMax} && ++$frame->{LoopCnt} > $frame->{LoopMax});

            	# evaluation loop expression (not on first time)
	    	$self->{Math}->EvalToScalar($replay->{For3}) if(exists $replay->{For3} and $frame->{LoopCnt} != 1);
            }

            # Evaluate the loop condition - if true keep looping
            my $bool = $self->EvalCond($replay, $dir, $place, $arg);
            next if($frame->{CondReRun});
            $self->closeFrame if( !$bool);

            next;
        }

        # Should only be seen at end of loop - which is buffered
        if($dir eq 'done') {
            return $self->SetError("Unexpected '$leadin$dir' at $place", 1)
                unless(exists $frame->{LoopMax});

            # Next to run is loop start:
            $frame->{CodeLine} = $frame->{LoopStart};
            $doneDone = 1;
            next;
        }

        if($dir eq 'break' or $dir eq 'last') {
            my $loops = 1;
            $loops = $1 if($arg =~ /\s*(\d+)/);

            # Unwind until we find a LoopEnd, then close that frame
            my $le;
            do {
                # Can't break out of sub:
                return $self->SetError("'$leadin$dir' too many loops at $place", 1)
                    if(exists $self->{Frame}->{ReturnFrom});

                $le = exists $self->{Frame}->{LoopEnd};
                return undef
                    unless($self->closeFrame);
            } until($le and --$loops <= 0);
            next;
        }

        if($dir eq 'continue' or $dir eq 'next') {
            my $loops = 1;
            $loops = $1 if($arg =~ /\s*(\d+)/);

            # Unwind until we find LoopStart, reset to that
            my $ls;
            while(1) {
                return $self->SetError("'$leadin$dir' too many loops at $place", 1)
                    if(exists $self->{Frame}->{ReturnFrom});

                if(($ls = exists $self->{Frame}->{LoopStart}) && --$loops <= 0) {
                    $self->{Frame}->{CodeLine} = $self->{Frame}->{LoopStart};
                    last;
                }

                return undef
                    unless($self->closeFrame);
            };

	    $doneDone = 1;    # This is like .done
            next;
        }

	# Local variable
        if($dir eq 'local') {
            # Push to previous var hash for this stack frame
            # This will be undone by closeFrame()
            foreach my $vname (split ' ', $arg) {
                my $vval = $vh->{$vname};
                $frame->{LocalVars}->{$vname} = $vval;
                delete($vh->{$vname});
            }
            next;
        }

	# Include another file
        if($dir eq 'include') {
            my (@push, @args, $stream, $fd);
            my $level = 0;

            if($arg =~ s/^-s\s*(\w+)\s*//) {
                $stream = $1;
                return $self->SetError("Stream '$stream' already open at $place")
                    if(exists($self->{Streams}->{$stream}));
            }

            return undef unless(@args = $self->SplitArgs($arg, 1));
            return $self->SetError("Missing include file at $place") unless(@args);
            my $fn = shift @args;

            # Push the include ?
            if(!defined($stream) and $fn =~ /^-p(\d*)$/) {
                $level = $1 eq '' ? 1 : $1;    # Default 1

                return $self->SetError("Attempt to push too far (" . (scalar @{$self->{FrameStk}}) . " available) at $place")
                    if($level > @{$self->{FrameStk}});
                return $self->SetError("Missing include file at $place") unless(@args);
                $fn = shift @args;
            }

            # Opening a pipe to read from ?
            if(substr($fn, 0, 1) eq '|') {
                return $self->SetError("Not allowed to open pipe at $place")
                    unless($self->{PipeOK});

                # Replace the command if written '|cmd'
                $fn = $fn eq '|' ? shift(@args) : substr($fn, 1);

                $fd = IO::Pipe->new;
                return $self->SetError("Open of pipe '$fn' failed: $! at $place")
                    unless($fd);

                $fd->reader($fn, @args);

                $fn = "| $fn";    # For messages, etc, only

                $vh->{_CountOpen}->[0]++;
            } else {
                return undef unless(defined($fn = $self->ResolveFilename($fn)));
                return $self->SetError("Cannot open file '$arg' at $place as $!")
                    unless($fd = $self->openFile($fn));
            }

            # Either store on a named stream or push to a frame
            if(defined($stream)) {
                $self->{Streams}->{$stream} = $fd;
            } else {
                $self->openFrame(Name => $fn, Fd => $fd, Args => [@args], Generate => 1, LineNumber => 0, ReturnFrom => 1);
                delete $self->{Frame}->{Code} if( !$level);  # Back to input from file unless pushed elsewhere
                if($level) {
                    # Insert opened stream/frame down in the stackframes:
                    my $str = pop @{$self->{FrameStk}};
                    splice @{$self->{FrameStk}}, -$level, 0, $str;
                }
            }

            next;
        }

        # Kill the script with optional exit code
        if($dir eq 'exit') {
            my $code = 2;
            if($arg ne '') {
                $code = $self->{Math}->ParseToScalar($arg);
                unless($code =~ /^\d+$/) {
                    print "Exit expression at $place was not numeric: $code\n";
                    $code = 2;
                }
            }
            exit $code;
        }

        # Print a line, -e print to stderr, -o stream write to named stream
        # Line parsed for escapes
        if($dir eq 'print') {
            my $stream = 'STDOUT';
            $stream = 'STDERR' if($arg =~ s/^-e\b\s*//);
            $stream = $1 if($arg =~ s/^-o\s*(\w+)\b\s*//);

            return undef unless(defined($arg = $self->ProcEscapes($arg)));
            $self->writeToStream($stream, "$arg\n");
            next;
        }

        # Set the current output stream
        if($dir eq 'out') {
            if($arg eq "") {
                $self->{out} = "";
            } elsif($arg =~ s/^(\w+)\s*$//) {
                if(defined($self->{OutStreams}->{$1})) {
                    $self->{out} = $1;
                } else {
                    $self->SetError("Unknown output stream '$1'");
                }
            } else {
                $self->SetError("Bad or missing stream name '$arg'");
            }
            next;
        }

        # Close this file, return to the one that .included it - if any
        # This may result in EOF. Check at loop top
        if($dir eq 'return') {
            # Evaluate expression after .return - in context of the .sub
            my $ret = undef;
            $ret = $self->{Math}->ParseToScalar($arg) if($arg =~ /\S/);
            $vh->{_} = [$ret];
            return undef
                unless($self->close);

            next;
        }

        # Eval: rewrite the line and try again
        if($dir eq 'eval') {
            return undef unless($_ = $self->ProcEscapes($arg));
            next if(/^$self->{DirStartRE}#/);
            $place = "Evaled: $place";
            goto EVAL_RESTART;
        }

        # Close a named stream
        if($dir eq 'close') {
            return $self->SetError("Missing option '-n stream' to ${leadin}close at $place", 1)
                unless($arg =~ s/^-s\s*(\w+)\s*//);

            my $stream = $1;

            $self->SetError("Unknown input stream '$stream' in ${leadin}read at $place", 1)
                unless(exists($self->{Streams}->{$stream}));

            delete($self->{Streams}->{$stream});    # Close it

            next;
        }

        # Read next line into var
        if($dir eq 'read') {
            my ($stream, $fd);

            $stream = $1 if($arg =~ s/^-s\s*(\w+)\s+//);

            my ($vname) = $arg =~ /^(\w+)/;
            return $self->SetError("Missing argument to ${leadin}read at $place", 1) unless($vname);

            # Find stream or Fd on stack:
            if(defined($stream)) {
                return $self->SetError("Unknown input stream '$stream' in ${leadin}read at $place", 1)
                    unless($fd = $self->{Streams}->{$stream});
            } else {
                # Find an open file
                my $f = $frame;
                my $i = @{$self->{FrameStk}} - 1;
                until(exists($f->{Fd})) {
                    $f = $self->{FrameStk}->[--$i];
                }
                $fd = $f->{Fd};
            }

            my $eof = 1;
            if($_ = $fd->getline) {
                chomp;
                $eof = 0;
                s/\s*$// if($self->{Trim});
            } else {
                $_ = '';
            }

            $vh->{$vname} = [$_];
            $vh->{'_EOF'} = [0 + $eof];
            $vh->{'_'}    = [1 - $eof];
            next;
        }

        # No operation
        next if($dir eq 'noop');

        # Subroutine definition
        if($dir eq 'sub') {
            return undef
                unless($self->readSub($dir, $_, $arg));
            next;
        }

        if($dir eq 'test') {
            my %an = ('-f' => 2);
            my @args = $self->SplitArgs($arg, 1);
            return $self->SetError("'$leadin$dir' bad or missing argument '$arg' at $place", 1)
                unless(@args and exists($an{$args[0]}) and @args == $an{$args[0]});

            if($args[0] eq '-f') {
                my ($fn, @stat);
                $vh->{_} = [0]; # assume error
                if(($fn = $self->ResolveFilename($args[1], 1)) and (@stat = stat $fn)) {
                    $vh->{_} = [1]; # OK
                    $vh->{_STAT} = [@stat];
                    $vh->{_TestFile} = [$fn];
                }
                next;
            }
        }

        if($dir eq 'error') {
            $arg = "Error at $place" if($arg eq '');
            return $self->SetError($arg);
        }

        if($dir eq 'set') {
            return $self->SetError("'$leadin$dir' bad argument '$arg' at $place")
                unless(($arg =~ /^(\w+)=(\d+)/) and $options{$1});
            $self->{$1} = $2;
            next;
        }

        return $self->SetError("Use of reserved directive '$leadin$dir' at $place", 1)
            if($dir eq 'function' or $dir eq 'do' or $dir eq 'case' or $dir eq 'switch' or $dir eq 'endswitch');

	# User defined sub.
        # At the bottom so cannot redefine an inbuilt directive
        if(exists($self->{subs}->{$dir})) {
            $self->RunSub($dir, $arg);

            next;
        }

        # Should not happen
        return $self->SetError("Unknown directive '$leadin$dir' at $place", 1);
    }
}

# Return the rest of input as an array
sub getlines
{
    my $self = shift;
    my @lines = ();

    return $self->SetError("A file has not been opened", 1)
        unless $self->{Fd};

    return $self->SetError("getlines called in a scalar context", 1)
        unless(wantarray);

    while(my $line = $self->getline) {
        push @lines, $line;
    }

    @lines
}

# Enable the object to be used in the diamond operator:
use overload '<>' => \&getline, fallback => 1;

1;

__END__