File Coverage

blib/lib/Template/Tiny.pm

Criterion	Covered	Total	%
statement	53	59	89.8
branch	19	24	79.1
condition	5	6	83.3
subroutine	9	9	100.0
pod	2	3	66.6
total	88	101	87.1

package Template::Tiny;

# Load overhead: 40k

use 5.00503;
use strict;

$Template::Tiny::VERSION = '1.12';

# 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 {
	bless { @_[1..$#_] }, $_[0];
}

# 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 || {};

	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 );
	if ( @_ ) {
		${$_[0]} = $result;
	} elsif ( defined wantarray ) {
		require Carp;
		Carp::carp('Returning of template results is deprecated in Template::Tiny 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];
	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 '';
		}
	}
	return $cursor;
}

1;

__END__