File Coverage

blib/lib/Text/Vpp.pm

Criterion	Covered	Total	%
statement	383	442	86.6
branch	149	212	70.2
condition	28	45	62.2
subroutine	33	37	89.1
pod	13	29	44.8
total	606	765	79.2

############################################################
#
# $Header: /home/domi/perlDev/Text_Vpp/RCS/Vpp.pm,v 1.27 2005/06/09 13:52:13 domi Exp $
#
# $Source: /home/domi/perlDev/Text_Vpp/RCS/Vpp.pm,v $
# $Revision: 1.27 $
# $Locker:  $
#
############################################################

package Text::Vpp;

require 5.6.0;
use strict;
use vars qw($VERSION);
use IO::File ;
use Carp ;

use AutoLoader qw/AUTOLOAD/ ;

$VERSION = '1.17' ;

# tiny FiFo "package"

sub F_new  { return [1]; }

sub F_reset { my $FiFo = $_[0]; $FiFo->[0]= 1; $#$FiFo= 0; }

sub F_tell { return $_[0]->[0]; }

sub F_seek { $_[0]->[0]= $_[1]; }

sub F_print { push @{$_[0]}, $_[1]; }

sub F_getline { my $FiFo = $_[0]; return $FiFo->[($FiFo->[0])++]; }

#---------------------


sub new
  {
    my $type = shift ;

    my $self      = {} ;
    my $file      = shift ;
    my $ref       = shift ;
    my $action    = shift ;
    my $comment   = shift ;
    my $prefix    = shift;
    my $suffix    = shift;
    my $substitute= shift;
    my $backslash = shift;

    if (defined $ref && (ref($ref) eq "HASH"))
      {
        $self->{var} = $ref ;
      }

    $self->{action}    = defined $action    ? $action    : '@' ;
    $self->{comment}   = defined $comment   ? $comment   : '#' ;
    $prefix= '$'  unless defined($prefix); #';  # for xemacs
    $self->{prefix}    = $prefix ;
    $self->{suffix}    = $suffix;
    $self->{substitute}= $substitute;
    $self->{backslash} = defined $backslash ? $backslash :  1  ;
    if ( UNIVERSAL::can($file,'getline') )
      { $self->{fileDesc}= $file; $self->{name}= ref($file); }
    else
      { $self->{fileDesc} = new IO::File;
        $self->{fileDesc}->open($file) || die "can't open $file \n";
        $self->{name} = $file ;
      }

    $self->{Fifo}= F_new;

    $self= bless $self,$type ;

    $self->setActionChar($self->{action});
    $self->setPrefixChar($self->{prefix});
    $self->setSuffixChar($self->{suffix});
    $self->setSubstitute($self->{substitute});
    $self->setCommentChar($self->{comment});

    return $self;
  }


sub myEval
  {
    my $self = shift ;
    my $expression = shift ;
    my $out = shift ;

    # transform each $xxx into $self->{var}{$xxx}
    # this allows for the creation of new variables
    # one may use the construction ${\w} to protect against this
    $expression =~ s[\$(\w+)\b] [\$self->{var}{$1}]g ;

    local *Vpp_Out= ref $out ? sub{push @$out,@_;} :
      sub {die "Cannot call Vpp_Out in \@INCLUDE line";} ;
    my $return = eval($expression) ;

    if ($@ ne "")
      {
        die "Error in eval : $@ \n",
        "line : $expression \nfile: $self->{name} line $.\n";
      }

    return ($return);
  }

sub ReplaceVars
  {
    my $self = shift ;

    $_[0] =~ s[\$({?)(\w+)\b(}?)]
      [if (defined($self->{var}{$2}))
       { "\$self->{var}{$2}" . ( !$1 ? $3 : '' ); }
       else {"\$$1$2$3";}
      ]ge ;

  }

sub myExpression
  {
    my $self = shift ;
    my $expression = shift ;

    $self->ReplaceVars($expression);

    my $return = eval($expression) ;

    if ($@ ne "")
      {
        die "Error in eval : $@ \n",
        "line : $expression \nfile: $self->{name} line $.\n";
      }

    return ($return);
  }


sub substitute
  {
    #return array ref made of new file
    my ($self,$fileOut) = @_ ;

    $self->{errorText} = [] ;
    $self->{error} = 0;

    $self->{IF_Level}= 0;  $self->{FOR_Level}= 0;

    my $res = $self->processBlock(1,1,0,0,0) ;

    chomp @$res ;

    if (defined $fileOut)
      {
        if ( UNIVERSAL::can($fileOut,'print') )
          {
            $fileOut->print(join("\n",@$res) ,"\n") ;
          }
        else
          {
            print "writing $fileOut\n";
            my $FileOut = $fileOut;
            $FileOut= ">$fileOut"  unless $fileOut =~/^>/;
            my $SubsOut = new IO::File;
            unless( $SubsOut->open($FileOut) )
              {
                $self->snitch("cannot open $fileOut") ;
                return 0 ;
              }
            print $SubsOut join("\n",@$res) ,"\n" ;
            close $SubsOut ;
          }
      }
    else
      {
        $self->{result} = $res ;
      }

    return  (not $self->{error} ) ;
  }

sub getText
  {
    my $self = shift ;
    return $self->{result} ;
  }

sub getErrors
  {
    my $self = shift  ;
    return $self->{errorText} ;
  }

sub Vpp_Out {croak "Original Vpp_Out called";}

sub do_shell
  {
    my $self=shift;
    my $shell_code = shift;
    my $out= `$shell_code`;
    warn "Error in SHELL code : status is $? \n",
      "in file: $self->{name} line $.\n",
        "code was\n$shell_code"  if  $? > 0;
    split(/\n/,$out) ;
  }

sub processBlock
  {
	# three parameters :
	# GlobExpand : false if nothing should be expanded
	# Expand : true if the calling ifdef is true
    my ($self,$globExpand,$expand,$EnterLoop,$useFiFo,$ScanOnly)=@_ ;
    $expand= 0  unless $globExpand;
    my $FiFo      = $self->{Fifo};

    my $out = [] ;

    # Done is used to evaluate the elsif
    my ($done) = $expand ;

    # Stage is used for syntax check
    my ($stage) = ($self->{IF_Level} == 0 || $EnterLoop) ? 0 : 1 ;

    my ($line,$keep,$SubsIt) ;
    local $/ = "\n";            # revert to standard line ending

    my $Within_Perl_Input = 0;
    my $Perl_Input_Termination;
    my $Perl_Code;

    my $Within_Shell_Input = 0;
    my $Shell_Input_Termination;
    my $Shell_Code;

    # attention: keep the following declaration in sync with
    #            the assignments whence processing 'EVAL' line
    my $action    = $self->{action} ;
    my $comment   = $self->{comment};
    my $prefix    = $self->{prefix} ;
    my $suffix    = $self->{suffix} ;
    my $substitute= $self->{substitute};
    my $backslash = $self->{backslash};
    my $VarPat    = $self->{VarPat};
    my $commentPat = $self->{commentPat};
    my $actionPat  = $self->{actionPat};
    my $ifPat      = $self->{ifPat};
    my $elsifPat   = $self->{elsifPat};
    my $elsePat    = $self->{elsePat};
    my $endifPat   = $self->{endifPat};
    my $includePat = $self->{includePat};
    my $evalPat    = $self->{evalPat};
    my $quotePat   = $self->{quotePat};
    my $endquotePat= $self->{endquotePat};
    my $subsPat    = $self->{subsPat};
    my $subsLeadPat= $self->{subsLeadPat};
    my $foreachPat = $self->{foreachPat};
    my $endforPat  = $self->{endforPat};
    my $perlPat    = $self->{perlPat};
    my $shellPat  = $self->{shellPat};

    if ( $useFiFo )
      {
        $line= F_getline($FiFo);
      }
    else
      {
        $line = $self->{fileDesc}->getline;
        F_print($FiFo,$line)  if  $ScanOnly;
      }

    while (defined($line))
      {
        if ( $Within_Perl_Input ) {
          if ( $line =~ /$Perl_Input_Termination/ ) {
            $Within_Perl_Input= 0;
            if ( $expand ) {
	      # $VAR may be used in eval'ed code
	      my $VAR = $self->{var} ;
	      local *Vpp_Out= sub {push @$out, @_; };
              my $res = eval($Perl_Code);
              die "Error in eval(uating) PERL code : $@ \n",
                "in file: $self->{name} line $.\n",
                "code was\n$Perl_Code"  if  $@;
            }
          } else {
            $Perl_Code.= $line;
          }
          next;
        }

        if ( $Within_Shell_Input ) {
          if ( $line =~ /$Shell_Input_Termination/ ) {
            $Within_Shell_Input= 0;
            push (@$out, $self->do_shell($Shell_Code)) if ( $expand );
          } else {
            $Shell_Code.= $line;
          }
          next;
        }

        chomp($line);
        #skip commented lines
        next if (defined $commentPat and $line =~ $commentPat);

        # get following line if the line is ended by \
        # (followed by tab or whitespaces)
        if ($backslash == 1 and $line =~ s/\\\s*$//)
          {
            $keep .= $line ;
            next ;
          }

        my $lineIn;
        if (defined $keep)
          {
            $lineIn = $keep.$line ;
            undef $keep ;
          }
        else
          {
            $lineIn = $line ;
          }

        study $lineIn;
        if ($lineIn =~ s/$ifPat//i)
          {
            # process the lines after the IF,
            # don't evaluate the boolean expression if  ! $expand
            my ($expandLoc) = $expand && $self->myExpression($lineIn) ;
            my $Current_IF_Level = $self->{IF_Level}++;
            push @$out,
            @{$self->processBlock($expand,$expandLoc,0,$useFiFo,$ScanOnly)};

            if ( $self->{IF_Level} != $Current_IF_Level )
              {
                $self->snitch("illegal nesting of FOREACH and IF"); return [];
	      }
          }
        elsif ($lineIn =~ s/$elsifPat//)
          {
            # process the lines after the ELSIF, done is set if the block
            # is expanded
            unless ($stage == 1 or $stage ==2)
              {
                $self->snitch("unexpected elsif");
              }
            $stage = 2 ;
            if ( $done )       # if-condition was true
              { $expand= 0; }  # now we are in the else
            else
              { # if-condition was false, so here we have a new chance
                $expand = $globExpand  &&  $self->myExpression($lineIn) ;
                $done = $expand ;
              }
          }
        elsif ($lineIn =~ $elsePat)
          {
            if ($stage == 0 || $stage == 3 )
              {
                $self->snitch("unexpected else");
              }
            $stage = 3 ;
            $expand = $globExpand  &&  !$done ;
          }
        elsif ($lineIn =~ $endifPat)
          {
            if ($stage == 0) {$self->snitch("unexpected endif");}
            $self->{IF_Level}--;
            return $out ;
          }
        elsif ($lineIn =~ s/$foreachPat//)
          {
            my ($emptyLoop,$Current_FOR_Level,$Start_of_Loop)
              = (1,$self->{FOR_Level},1);

            if ( $expand )
              {
                my $LoopExpr = $lineIn;
                $LoopExpr =~ s/^\s*my\s//;  # remove my if there
                my $LoopVar ;
		$LoopVar = $1 if $LoopExpr =~ s/\$(\w+)//;

                $self->ReplaceVars($LoopExpr);
                my @LoopList= eval $LoopExpr;
                if ( $@ )
                  {
                    die "Error in FOREACH-List-Expression: $@\n",
                    "line : $lineIn\nfile: $self->{name} line $.\n";
                  }
                $emptyLoop= scalar(@LoopList) == 0;

                unless ($emptyLoop)
                  {
                    if ( $self->{FOR_Level} == 0 )
                      {
                        F_reset($FiFo);
                        $self->{FOR_Level}++;
                        $self->processBlock(0,0,1,0,1); # Scan Only
                        if ( $Current_FOR_Level != $self->{FOR_Level} )
                          {
                            $self->snitch("illegal nesting for IF and FOREACH");
                            return [];
                          }
                        $Start_of_Loop= 1;
                      }
                    else { $Start_of_Loop= F_tell($FiFo); }

                    foreach my $LpVar (@LoopList)
                      {
                        $self->{var}{$LoopVar}= $LpVar;
                        $self->{FOR_Level}++;
                        F_seek($FiFo,$Start_of_Loop);

                        push @$out, @{$self->processBlock(1,1,1,1,0)} ;

                        if ( $Current_FOR_Level != $self->{FOR_Level} )
                          {
                            $self->snitch("illegal nesting for IF and FOREACH");
                            return [];
                          }
                      }
                  }
              }

            if ($emptyLoop) # loop has never been executed
              {
                if ( $self->{FOR_Level} == 0 )
                  {
                    $self->{FOR_Level}++;
                    $self->processBlock(0,0,1,0,0); # just skip
                  }
                else
                  {
                    $self->{FOR_Level}++;
                    $self->processBlock(0,0,1,$useFiFo,$ScanOnly); # process but don't expand
                  }
                if ( $Current_FOR_Level != $self->{FOR_Level} )
                  {
                    $self->snitch("illegal nesting for IF and FOREACH");
                    return [];
                  }
              }
          }
        elsif ($lineIn =~ $endforPat)
          {
            $self->{FOR_Level}--; return $out;
          }
        elsif ($lineIn =~ $includePat)
          {
            if ( $expand )
              {
                # look like we've got a new file to slurp
                $lineIn =~ s/$includePat//;
                my $newFile;
                my $Incl = $lineIn =~ /^[\w_\-.]+$/ ?
                  $lineIn : $self->myEval($lineIn);

                if ( ref($Incl) eq 'HASH' )
                  {
                    $Incl->{action}=	$action     unless defined $Incl->{action};
                    $Incl->{comment}=	$comment    unless defined $Incl->{comment};
                    $Incl->{prefix}=	$prefix     unless defined $Incl->{prefix};
                    $Incl->{suffix}=	$suffix     unless defined $Incl->{suffix};
                    $Incl->{substitute}=    $substitute unless defined $Incl->{substitute};
                    $Incl->{backslash}=	$backslash  unless defined $Incl->{backslash};
                    unless ( defined $Incl->{file} )
                      {
                        $self->snitch("illegal file at include $lineIn");
                        return [];
                      }

                    $newFile =  Text::Vpp-> new ($Incl->{file}, $self->{var},
                                                 $Incl->{action}, $Incl->{comment},
                                                 $Incl->{prefix}, $Incl->{suffix},
                                                 $Incl->{substitute}, $Incl->{backslash});
                  }
                else
                  {
                    $newFile =  Text::Vpp-> new ($Incl, $self->{var},
				                 $action,$comment,$prefix,$suffix,
                                                 $substitute,$backslash) ;
                  }

                if ($newFile->substitute())
                  {
                    my $res = $newFile->getText() ;
                    push @$out, @$res ;
                  }
                else
                  {
                    # an error occured
                    push @{$self->{errorText}}, @{$newFile->getErrors()} ;
                    $self->{error} = 1;
                    return $out  ;
                  }
                undef $newFile ;
              }
          }
        elsif ($lineIn =~ s/$evalPat//)
          {
            if ( $expand ) {$self->myEval($lineIn, $out);}

            # reassign in case there was a change to some
            # of the following
            # attention: keep the following assignments in sync with
            #            with the declarations at the beginning of this sub
            $action     = $self->{action} ;
            $comment    = $self->{comment};
            $prefix     = $self->{prefix} ;
            $suffix     = $self->{suffix} ;
            $substitute = $self->{substitute};
            $backslash  = $self->{backslash};
            $VarPat     = $self->{VarPat};
            $commentPat = $self->{commentPat};
            $actionPat  = $self->{actionPat};
            $ifPat      = $self->{ifPat};
            $elsifPat   = $self->{elsifPat};
            $elsePat    = $self->{elsePat};
            $endifPat   = $self->{endifPat};
            $includePat = $self->{includePat};
            $evalPat    = $self->{evalPat};
            $quotePat   = $self->{quotePat};
            $endquotePat= $self->{endquotePat};
            $subsPat    = $self->{subsPat};
            $subsLeadPat= $self->{subsLeadPat};
            $foreachPat = $self->{foreachPat};
            $endforPat  = $self->{endforPat};
            $perlPat    = $self->{perlPat};
            $shellPat   = $self->{shellPat};
          }
        elsif ($lineIn =~ s/$perlPat//)
          {  $Within_Perl_Input= 1;
             $Perl_Code= "";
             $lineIn =~ s/\s*$//;
             $Perl_Input_Termination= qr/$lineIn/;
          }
        elsif ($lineIn =~ s/$shellPat//)
          {
            if ($lineIn =~ s/<<\s*//)
              {
                $Within_Shell_Input= 1;
                $Shell_Code= "";
                $lineIn =~ s/\s*$//;
                $Shell_Input_Termination= qr/$lineIn/;
              }
            else
              {
                push @$out, $self->do_shell($lineIn);
              }
          }
        elsif ( $lineIn =~ /$quotePat/ )
          {
            my $Str = $lineIn; $Str =~ s/$quotePat//;
            my ($ListSeparator,$ListPrefix);
            #  format   @QUOTE (ListPrefix,ListSeparator)
            if ( $Str =~ /^\(/ )
              {
                if ( $Str =~ /^\(\s*(\S)([^\1]*?)\1\s*(?:,\s*(\S)([^\2]*?)\3\s*\))?/ )
                  { $ListPrefix= $2; $ListSeparator= $4; }
                else { $self->snitch("illegal QUOTE action : $lineIn"); }
              }
            $Str= '';

            while(1)
              {
                if ( $useFiFo ) { $line= F_getline($FiFo); }
                else
                  {
                    $line = $self->{fileDesc}->getline;
                    F_print($FiFo,$line)  if  $ScanOnly;
                  }
                last if $line =~ $endquotePat;

                unless ( defined $line )
                  {
                    $self->snitch("EOF while scanning QUOTE");
                    return [];
                  }

                $Str.= $line if ( $expand );
              }

            if ( $expand )
              {
                # protect '$' and '@'
                if ( "$prefix$suffix" !~ /\$/
                     && ( !defined($ListPrefix)  || $ListPrefix !~ /\$/ ) )
                  { $Str =~ s/(?

                if ( "$prefix$suffix" !~ /\@/
                     && ( !defined($ListPrefix)  || $ListPrefix !~ /\@/ ) )
                  { $Str =~ s/(?

                if ( defined $ListPrefix ) { $Str =~ s/\Q$ListPrefix\E/\@/g; }

                # substitute variables
                if ( defined $suffix )
                  {
                    $Str =~ s[$VarPat][\$self->{var}{$1}]g;
                  }
                else
                  {
                    $Str =~ s[$VarPat]
                      [ { "\$self->{var}{$2}" . ( !$1 ? $3 : '' ) ;} ]ge ;
                  }

                if ( defined $ListSeparator )
                  { local $"= $ListSeparator; $Str = eval("qq($Str)"); }
                else { $Str = eval("qq($Str)"); }

                if ($@ ne "")
                  {
                    die "Error in QUOTE/eval : $@ \n",
                    "expression:\n$Str\n\nfile: $self->{name} line $.\n";
                  }

                chomp $Str;
                push @$out, split /\n/,$Str;
              }
          }
        elsif ( $SubsIt=($lineIn =~ $subsLeadPat)  ||  $lineIn !~ $actionPat )
          {
            # process the line
            if ($expand)
              {
                if ( $SubsIt )  # eval substitution parts
                  {
                    $lineIn =~ s/$subsPat/$self->myExpression($1)/ge;
                  }

                # substitute variables
                if ( defined $suffix )
                  {
                    $lineIn =~ s[$VarPat]
                      [ if (defined($self->{var}{$1}))
                        { $self->{var}{$1};}
                        else    {"$prefix$1$suffix"  ;}
                      ]ge ;
                  }
                else
                  {
                    $lineIn =~ s[$VarPat]
                      [ if (defined($self->{var}{$2}))
                        { $self->{var}{$2} . ( !$1 ? $3 : '' ) ;}
                        else    {"$prefix$1$2$3"  ;}
                      ]ge ;
                  }

                push @$out, $lineIn ;
              }
          }
        else
          {
            $self->snitch("Unknown command :$lineIn") ;
          }
      }

    continue
      {
        if ( $useFiFo )
          { $line= F_getline($FiFo); }
        else
          {
            $line = $self->{fileDesc}->getline;
            F_print($FiFo,$line)  if  $ScanOnly;
          }
      }


    if ($self->{IF_Level} > 0 )
      {
        $self->snitch("Finished inside a conditionnal block");
      }
    elsif ( $self->{FOR_Level} > 0 )
      {
        $self->snitch("Finished inside a FOREACH block");
      }

    return $out ;
  }

1;

__END__