File Coverage

blib/lib/Text/Macro.pm

Criterion	Covered	Total	%
statement	289	298	96.9
branch	86	116	74.1
condition	9	15	60.0
subroutine	40	41	97.5
pod	5	11	45.4
total	429	481	89.1

########################################
# Module: Text::Macro
# Purpose: A text macro-language almost identical to Text::FastTemplate
# Author: Michael Maraist
# Derived from: Text::FastTemplate
########################################

package Text::Macro;
use strict;
use warnings;
use integer;
use IO::File;

our %cache;

require 5.006;
our $VERSION = '0.07';

use fields qw( filename path code src stack blocks switch_stack line subs for_sep );

########################################
# Function: new
########################################
sub new {
  my $self = shift;
  my %args = @_;
  my $filename = $args{file} or die "No file-name provided";
  my $path = "";
  if ( exists $args{path} ) {
      $path = $args{path};
      if ( ! $path =~ m!/$! ) {
          $path .= "/";
      }
  }

  if ( exists $cache{ $filename } ) {
        return $cache{ $filename };
  }

  my Text::Macro $this = fields::new( $self );

  $this->{filename} = $filename;
  $this->{path} = $path;

  $this->parse( );
  $cache{ $filename } = $this;
  return $this;
} # end new

########################################
# Function: readFile
# Purpose:  recursive file-reader.  Actively handles include-directives
# IN:       file-name
# Throws:   couldn't open file
########################################
sub readFile($$)
{
    my Text::Macro $this = shift;
    my $file = shift;
    my $file_name = $this->{path} . $file;

    my $fh = new IO::File $file_name
        or die "Could not load file: $file_name";
    my $idx = 1;
    return map {
         /^\s*\#include\s+(.*)\n$/ ? $this->readFile( $1 ) : [ $_, $idx++, $file  ];
    } $fh->getlines();
} # end readFile

########################################
#
########################################
sub compileError($$)
{
    my ( $msg, $block ) = @_;
    print STDERR "Error: $msg; $block->[1] $block->[2]: $block->[0]";
    exit(-1);
} # end compileError

########################################
# Function: getText
# Purpose:  get the next raw string piece of text
########################################
sub getTextBlock($)
{
    my ( $blocks ) = @_;
    my $line_chunks;
    # extract line chunks (consolidating with previous line if possible.
    $_ = $blocks->[ $#$blocks ];
    if ( ref( $_ ) ne "ARRAY" ) {
        $line_chunks = [];
        push @$blocks, $line_chunks;
    } else {
        $line_chunks = $_;
    }

    return $line_chunks;
} # end getTextBlock

########################################
# Function: concatText
# Purpose:  concatenate text to an existing print-statement
########################################
sub concatText($$)
{
    my ( $line_block, $txt ) = @_;
    $txt =~ s/\'/\\\'/g;
    my $str = $line_block->[-1];
    if ( defined $str && substr( $str, -1, 1 ) eq "'") {
        # previous piece of text was string; concat
        substr( $str, -1, 0, $txt );
        $line_block->[-1] = $str;
    } else {
        push @$line_block, "'$txt'";
    }
} # end concatText

##################################################
# Function: parseSection
# Purpose:  convert the input blocks file into perl code
# ToDo:     Make sure that the input is properly escaped
##################################################
sub parseSection($@)
{
    my Text::Macro $this = shift;
    my @lines = @_;

    for ( my $line_idx = 0; $line_idx <= $#lines ; $line_idx++ ) {
        my $line_block = $lines[$line_idx];

        my $line = $line_block->[0];

        # Determine if we're a command
        if ( my ( $cmd, $cond ) = $line =~ /
            ^ \s*\#( if | for | elsif | else  | endif | endfor | comment | sub | callsub | pre | switch | case | endswitch | default | set )\b \s* (.*) \n $
            /x ) {
            # We are a command
            if ( $cmd eq "if" ) {
                compileError( "No if conditional", $line_block )
                    unless $cond;

                {
                    no warnings;
                    # pre-process cond
                    $cond =~ s/\#\#(\w+)([\[\{][^\#]+)?\#\#/\$scope->{$1}$2/gs;
                }

                push @{$this->{blocks}}, "if ( $cond ) {\n";
                push @{$this->{stack}}, "i";
                next;
            } elsif ( $cmd eq "set" ) {
                compileError( "No if conditional", $line_block )
                    unless $cond;
                my ( $var, $val ) = split( "=", $cond );
                compileError( "Need a variable", $line_block )
                    unless $var;

                my @txt;
                for ( split( /(\#\#[\w\{\[\}\]]+\#\#)/, $val ) ) {
                    my ( $var_name, $ref_data ) = /^\#\#(\w+)([\[\{][^\#]+)?\#\#$/;
                    if ( $var_name ) {
                        $ref_data = "" unless defined $ref_data;
                        push @txt, "\$scope->{$var_name}$ref_data";
                    } else {
                        push @txt, '"' . quotemeta( $_ ) . '"';
                    }
                }
                push @{$this->{blocks}}, "\$scope->{$var} = ", join( " . ", @txt ) ,";";
            } elsif ( $cmd eq "switch" ) {
                my ( $var ) = $cond =~ /\#\#(\w+)\#\#/;
                compileError( "No switch argument", $line_block )
                    unless $var;

                push @{$this->{switch_stack}}, [ $var, 1 ];
                push @{$this->{stack}}, "s";
            } elsif ( $cmd eq "endswitch" ) {
                compileError( "Exiting $this->{stack}[-1] when still in switch", $line_block )
                    unless $this->{stack}[-1] eq "s" || $this->{stack}[-1] eq "d";
                pop @{$this->{stack}};
                push @{$this->{blocks}}, "}\n" unless $this->{switch_stack}[-1][1];
                pop @{$this->{switch_stack}};
            } elsif ( $cmd eq "case" ) {
                my ( @syms ) = $cond =~ /(\"[^\"]+\")/g;
                compileError( "No conditional value", $line_block )
                    unless @syms;
                compileError( "case with no switch", $line_block )
                    unless @{$this->{switch_stack}};
                my $switch_item = $this->{switch_stack}[-1];
                my $sym_str = "(" . join( ') || (', map { "\$scope->{$switch_item->[0]} eq $_" } @syms ) . ")";
                if ( $switch_item->[1] ) {
                    push @{$this->{blocks}}, "if ( $sym_str ) {\n";
                    $switch_item->[1] = 0;
                } else {
                    push @{$this->{blocks}}, "} elsif ( $sym_str ) {\n";
                }
            } elsif ( $cmd eq "default" ) {
                compileError( "case with no switch", $line_block )
                    unless @{$this->{switch_stack}};
                my $switch_item = $this->{switch_stack}[-1];
                if ( $switch_item->[1] ) {
                } else {
                    push @{$this->{blocks}}, "} else {\n";
                }
                $this->{stack}[-1] = "d";
            } elsif ( $cmd eq "pre" ) {
                my $line_chunks;
                $line_chunks = getTextBlock($this->{blocks});
                # Gobble up the remainder of the sub for later use
                for ( $line_idx++ ; $line_idx <= $#lines && ( ( $line = ($line_block = $lines[$line_idx])->[0] ) !~ /^\s*\#endpre/ ) ; $line_idx++ ) {
                    concatText( $line_chunks, $line );
                }

            } elsif ( $cmd eq "sub" ) {
                my ($sub_name) = $cond =~ /(\w+)/;
                compileErrot( "No sub-name", $line_block )
                    unless $sub_name;

                my @sub_data = ();

                # Gobble up the remainder of the sub for later use
                for ( $line_idx++ ;
                      $line_idx <= $#lines && ( ( $line = ($line_block = $lines[$line_idx])->[0] ) !~ /^\s*\#endsub/ ) ;
                      $line_idx++ ) {
                    push @sub_data, $line_block;
                }
                $this->{subs}{$sub_name} = \@sub_data;
            } elsif ( $cmd eq "callsub" ) {
                my ($sub_name, $params) = $cond =~ /(\w+)\s*(\S.*)?/;
                compileError( "No sub-name", $line_block )
                    unless $sub_name;

                compileError( "sub-macro '$sub_name' not defined", $line_block )
                    unless exists $this->{subs}{$sub_name};

                if ( $params ) {
                    no warnings;
                    # pre-process cond
                    $params =~ s/\#\#(\w+)([\[\{][^\#]+)?\#\#/\$scope->{$1}$2/gs;

                    push @{$this->{blocks}}, "{ my \$save_argv = \$scope->{ARGV};\n\$scope->{ARGV} = [$params];\n";
                }

                $this->parseSection( @{$this->{subs}{$sub_name}} );
                if ( $params ) {
                    push @{$this->{blocks}}, "\n\$scope->{ARGV} = \$save_argv;\n}\n";
                }
            } elsif ( $cmd eq "for" ) {
                my ($var) = $cond =~ /\#\#(\w+)\#\#/
                    or compileError( "No conditional", $line_block );
                #$this->{for_sep} = "";
                if ( $cond =~ /; sep="(.*?)"/ ) {
                    push @{$this->{for_sep}}, "(\$counter == \@loop_var ? \"\" : \"$1\" )";
                } else {
                    push @{$this->{for_sep}}, "";
                }
                push @{$this->{stack}}, "f";
                #ZZZ make size, idx, and comma exist only if used
                push @{$this->{blocks}}, <
\{ my \$old_scope = \$scope;
  my \@loop_var = (exists \$scope->{$var} && ref(\$scope->{$var}) eq "ARRAY" ) ? \@{\$scope->{$var}} : ();
  my \$counter = 0;
  for my \$el ( \@loop_var ) \{
    \$scope = defined(\$el) && ref(\$el) eq "HASH" ? { \%\$el } : {};
    for my \$scope_name ( grep { !exists \$scope->{ \$_ } } keys \%\$old_scope ) {
        \$scope->{ \$scope_name } = \$old_scope->{ \$scope_name };
    }
    \$scope->{${var}_SIZE} = scalar \@loop_var;
    \$scope->{${var}_IDX} = ++\$counter;

EOS
        } elsif ( $cmd eq "else" ) {
            compileError( "else not level with if", $line_block )
              unless $this->{stack}[ $#{$this->{stack}} ] eq "i";

        $this->{stack}[ $#{$this->{stack}} ] = "e"; # pop/push
        push @{$this->{blocks}}, "} else {\n";
      } elsif ( $cmd eq "elsif" ) {
        compileError( "No conditional", $line_block )
          unless $cond;
        compileError( "elsif not level with if", $line_block )
          unless $this->{stack}[ $#{$this->{stack}} ] eq "i";

        # pre-process cond
        #Note that this searches for either ##var## or ##var[x][y]## or ##var{x}{y}##.
        {
            no warnings;
            $cond =~ s/\#\#(\w+)([\[\{][^\#]+)?\#\#/\$scope->{$1}$2/sg;
        }


        push @{$this->{blocks}}, "} elsif ( $cond ) {\n";
      } elsif ( $cmd eq "endif" ) {
        $_ = $this->{stack}[ $#{$this->{stack}} ];
        compileError( "endif not level with if", $line_block )
          unless $_ eq "i" || $_ eq "e";
        pop @{$this->{stack}};
        push @{$this->{blocks}}, "}\n";
      } elsif ( $cmd eq "endfor" ) {
        compileError( "endfor not level with for", $line_block )
          unless $this->{stack}[ $#{$this->{stack}} ] eq "f";
        pop @{$this->{stack}};
        if ( length $this->{for_sep}[-1] ) {
            my $line_block = getTextBlock( $this->{blocks} );
            push @$line_block, $this->{for_sep}[-1];
            #concatText( $line_block, $for_sep );
        }
        push @{$this->{blocks}}, "}\n\$scope=\$old_scope;\n}\n";
        pop @{$this->{for_sep}};
      } elsif ( $cmd eq "comment" ) {
        # ignore line
      } else {
        compileError( "Invalid command state", $line_block );
      }
    } else { # if command
        # We weren't a command
        my $line_chunks = getTextBlock( $this->{blocks} );

      # replace "##\w+[x]##" with a variable insertion point or raw text
      for ( split( /(\#\#[\w\{\[\}\]]+\#\#)/, $line ) ) {
          my ( $var_name, $ref_data ) = /^\#\#(\w+)([\[\{][^\#]+)?\#\#$/;
          if ( $var_name ) {
              $ref_data = "" unless defined $ref_data;
              push @$line_chunks, "\$scope->{$var_name}$ref_data";
          } else {
              concatText( $line_chunks, $_ );
          }
      }
    } # end else (not command)
  } # end readlines

} # end parseSection


##################################################
# Function: parse
# Purpose:  convert the input template file into perl code
# ToDo:     Make sure that the input is properly escaped
##################################################
sub parse($)
{
    my Text::Macro $this = shift;

    my @lines = $this->readFile( $this->{filename} );

    $this->{for_sep} = [];
    $this->{blocks} = [];
    $this->{stack} = [];
    $this->{switch_stack} = [];
    $this->{subs} = {};

    $this->parseSection( @lines );

    die "stack not unraveled at end of input"
        if @{$this->{stack}};

    # Convert text-chunks to print statements
    for my $block ( @{$this->{blocks}} ) {
        if ( ref( $block ) eq "ARRAY" ) {
            for( @$block ) {
                s!\\\n!!;
            }
            $block = "\$fh->( " . join( ", ", @$block ) . ");\n";
        }
    }

    my @code = (
                "sub {\nno warnings;\nmy \$tmp = shift; my \$scope = { \%\$tmp };\nmy \$fh = shift;\n",
                @{$this->{blocks}},
                "};\n"
               );
    my $src = "@code";
    $this->{src} = $src;
    #print "CODE{$this->{src}\nCODE}\n";
    my $code = eval $src;

    $this->{code} = $code;
} # end parse

########################################
# Function: print
########################################
sub print($$) {
  my Text::Macro $this = shift;
  my $data = shift;
  die "Compilation error"
      unless $this->{code};
  no warnings;
  $this->{code}->( $data, sub { print @_; });
} # end print

sub pipe($$$) {
  my Text::Macro $this = shift;
  my $data = shift;
  my $fh = shift;

  die "Compilation error"
      unless $this->{code};
  no warnings;
  $this->{code}->( $data, sub { print $fh @_;  } );
} # end pipe

sub toFile($$$) {
    my Text::Macro $this = shift;
    my $data = shift;
    my $file_name = shift;

    my $fh = new IO::File ">$file_name"
        or die "Could not open file: $file_name";

    $this->pipe( $data, $fh );

    $fh->close();
} # end toFile

sub toString($$) {
  my ( $this, $data ) = @_;

  die "Compilation error"
      unless $this->{code};

  my @contents;
  no warnings;
  $this->{code}->( $data, sub {  push @contents, @_; } );
  return join( "", @contents );
} # end toString

1;

__END__