File Coverage

blib/lib/Template/Tiny/Strict.pm

Criterion	Covered	Total	%
statement	77	83	92.7
branch	33	38	86.8
condition	10	11	90.9
subroutine	9	9	100.0
pod	3	4	75.0
total	132	145	91.0

package Template::Tiny::Strict;

# ABSTRACT: Template Toolkit reimplemented in as little code as possible

# Load overhead: 40k

use strict;

our $VERSION = '1.17';

# Evaluatable expression
my $EXPR = qr/ [a-z_][\w.]* /xs;

# Opening [% tag including whitespace chomping rules
my $LEFT = qr/
	(?:
		(?: (?:^|\n) [ \t]* )? \[\%\-
		|
		\[\% \+?
	) \s*
/xs;

# Closing %] tag including whitespace chomping rules
my $RIGHT = qr/
	\s* (?:
		\+? \%\]
		|
		\-\%\] (?: [ \t]* \n )?
	)
/xs;

# Preparsing run for nesting tags
my $PREPARSE = qr/
	$LEFT ( IF | UNLESS | FOREACH ) \s+
		(
			(?: \S+ \s+ IN \s+ )?
		\S+ )
	$RIGHT
	(?!
		.*?
		$LEFT (?: IF | UNLESS | FOREACH ) \b
	)
	( .*? )
	(?:
		$LEFT ELSE $RIGHT
		(?!
			.*?
			$LEFT (?: IF | UNLESS | FOREACH ) \b
		)
		( .+? )
	)?
	$LEFT END $RIGHT
/xs;

# Condition set
my $CONDITION = qr/
	\[\%\s
		( ([IUF])\d+ ) \s+
		(?:
			([a-z]\w*) \s+ IN \s+
		)?
		( $EXPR )
	\s\%\]
	( .*? )
	(?:
		\[\%\s \1 \s\%\]
		( .+? )
	)?
	\[\%\s \1 \s\%\]
/xs;

sub new {
    my ( $class, %arg_for ) = @_;
    return bless {
        TRIM          => $arg_for{TRIM},
        forbid_undef  => $arg_for{forbid_undef},
        forbid_unused => $arg_for{forbid_unused},
        name          => ( $arg_for{name} // 'template' ),
        _undefined    => {},
        _used         => {},
    } => $class;
}

sub name { $_[0]->{name} }

# Copy and modify
sub preprocess {
    my $self = shift;
    my $text = shift;
    $self->_preprocess( \$text );
    return $text;
}

sub process {
    my $self  = shift;
    my $copy  = ${ shift() };
    my $stash = shift || {};
    $self->{_undefined} = {};
    $self->{_used}      = {};

    local $@  = '';
    local $^W = 0;

    # Preprocess to establish unique matching tag sets
    $self->_preprocess( \$copy );

    # Process down the nested tree of conditions
    my $result = $self->_process( $stash, $copy );
    my $errors = '';
    if ( $self->{forbid_undef} ) {
        if ( my %errors = %{ $self->{_undefined} } ) {
            $errors = join "\n" => sort keys %errors;
        }
    }
    if ( $self->{forbid_unused} ) {
        my @unused;
        foreach my $var ( keys %$stash ) {
            unless ( $self->{_used}{$var} ) {
                push @unused => $var;
            }
        }
        if ( my $unused = join ', ' => sort @unused ) {
            $errors
              .= "\nThe following variables were passed to the template but unused: '$unused'";
        }
    }
    if ($errors) {
        require Carp;
        my $name = $self->name;
        my $class = ref $self;
        $errors = "$class processing for '$name' failed:\n$errors";
        Carp::croak($errors);
    }

    if (@_) {
        ${ $_[0] } = $result;
    }
    elsif ( defined wantarray ) {
        require Carp;
        Carp::carp(
            'Returning of template results is deprecated in Template::Tiny::Strict 0.11'
        );
        return $result;
    }
    else {
        print $result;
    }
}

######################################################################
# Support Methods

# The only reason this is a standalone is so we can
# do more in-depth testing.
sub _preprocess {
    my $self = shift;
    my $copy = shift;

    # Preprocess to establish unique matching tag sets
    my $id = 0;
    1 while $$copy =~ s/
		$PREPARSE
	/
		my $tag = substr($1, 0, 1) . ++$id;
		"\[\% $tag $2 \%\]$3\[\% $tag \%\]"
		. (defined($4) ? "$4\[\% $tag \%\]" : '');
	/sex;
}

sub _process {
    my ( $self, $stash, $text ) = @_;

    $text =~ s/
		$CONDITION
	/
		($2 eq 'F')
			? $self->_foreach($stash, $3, $4, $5)
			: eval {
				$2 eq 'U'
				xor
				!! # Force boolification
				$self->_expression($stash, $4)
			}
				? $self->_process($stash, $5)
				: $self->_process($stash, $6)
	/gsex;

    # Resolve expressions
    $text =~ s/
		$LEFT ( $EXPR ) $RIGHT
	/
		eval {
			$self->_expression($stash, $1)
			. '' # Force stringification
		}
	/gsex;

    # Trim the document
    $text =~ s/^\s*(.+?)\s*\z/$1/s if $self->{TRIM};

    return $text;
}

# Special handling for foreach
sub _foreach {
    my ( $self, $stash, $term, $expr, $text ) = @_;

    # Resolve the expression
    my $list = $self->_expression( $stash, $expr );
    unless ( ref $list eq 'ARRAY' ) {
        return '';
    }

    # Iterate
    return join '',
      map { $self->_process( { %$stash, $term => $_ }, $text ) } @$list;
}

# Evaluates a stash expression
sub _expression {
    my $cursor = $_[1];
    my @path   = split /\./, $_[2];
    $_[0]->{_used}{ $path[0] } = 1;
    foreach (@path) {

        # Support for private keys
        return undef if substr( $_, 0, 1 ) eq '_';

        # Split by data type
        my $type = ref $cursor;
        if ( $type eq 'ARRAY' ) {
            return '' unless /^(?:0|[0-9]\d*)\z/;
            $cursor = $cursor->[$_];
        }
        elsif ( $type eq 'HASH' ) {
            $cursor = $cursor->{$_};
        }
        elsif ($type) {
            $cursor = $cursor->$_();
        }
        else {
            return '';
        }
    }
    if ( $_[0]->{forbid_undef} && !defined $cursor ) {
        my $path = join '.' => @path;
        $_[0]->{_undefined}{"Undefined value in template path '$path'"} = 1;
        return '';
    }

    return $cursor;
}

1;

__END__