File Coverage

blib/lib/Template/Compiled.pm

Criterion	Covered	Total	%
statement	120	137	87.5
branch	35	54	64.8
condition	4	6	66.6
subroutine	20	25	80.0
pod	2	2	100.0
total	181	224	80.8

use 5.008;
use strict;
use warnings;

package Template::Compiled;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.002';

use Eval::TypeTiny qw( eval_closure );
use Types::Standard qw( -types slurpy Join );
use Type::Params 1.002000 qw( compile_named );
use Carp qw( croak confess );
use B qw( perlstring );

use constant PERL_NATIVE_ALIASES => ($] >= 5.02200);

use Moo;
use namespace::autoclean;

use overload
	'""'         => sub { $_[0]->template },
	'bool'       => sub { !!1 },
	'&{}'        => sub { $_[0]->sub },
	fallback     => 1,
	;

has template => (
	is        => 'ro',
	isa       => Str->plus_coercions( Join["\n"] ),
	required  => !!1,
	coerce    => !!1,
);

has signature => (
	is        => 'ro',
	isa       => Maybe[ArrayRef],
	predicate => !!1,
	required  => !!0,
);

has delimiters => (
	is        => 'lazy',
	isa       => Tuple[Str, Str],
	builder   => sub { [qw/  /] },
);

has escape => (
	is        => 'ro',
	isa       => CodeRef->plus_coercions(Str, \&_lookup_escaping),
	required  => !!0,
	predicate => !!1,
	coerce    => !!1,
);

has trim => (
	is        => 'lazy',
	isa       => Bool,
	builder   => sub { !!0 },
);

has outdent => (
	is        => 'lazy',
	isa       => Int,
	builder   => sub { 0 },
);

has post_process => (
	is        => 'ro',
	isa       => CodeRef,
	required  => !!0,
	predicate => !!1,
);

has utils_package => (
	is        => 'lazy',
	isa       => Str,
	builder   => sub { __PACKAGE__ . '::Utils' },
);

has 'sub' => (
	is        => 'lazy',
	isa       => CodeRef,
	builder   => sub {
		my ($code, $env) = $_[0]->_build_code_and_env;
		eval_closure(
			source      => $code,
			environment => $env,
			description => 'template prelude',
		);
	},
);

sub print {
	my $self = shift;
	my $fh   = FileHandle->check($_[0]) ? shift() : undef;

	defined($fh)
		? $fh->print( $self->render(@_) )
		: CORE::print( $self->render(@_) );
}

sub render {
	my $self = shift;
	$self->sub->(@_);
}

sub _build_code_and_env {
	my $self = shift;

	my @code;
	my %env;

	push @code, 'sub {';
	push @code, sprintf('use %s;', $self->utils_package);

	push @code, 'sub _ ($);';
	push @code, '*_ = sub ($) { goto $_ESCAPE };';
	$env{'$_ESCAPE'} = \ do { $self->escape or sub { $_[0] } };

	push @code, 'local %_;';
	push @code, 'my ($OUT, $INDENT) = (q(), q());';
	push @code, 'our $_OUT_REF = \\$OUT;';

	if (PERL_NATIVE_ALIASES) {
		push @code, 'use feature qw( refaliasing );';
		push @code, 'no warnings qw( experimental::refaliasing );';
	}

	if ($self->has_signature) {
		push @code, '%_ = %{ $_SIGNATURE->(@_) };';
		$env{'$_SIGNATURE'} = \ do { compile_named(@{ $self->signature }) };
	}
	else {
		push @code, '%_ = (@_==1 and ref($_[0]) eq "HASH") ? %{$_[0]} : @_%2 ? Carp::croak("Expected even-sized list of arguments") : @_;';
	}

	if ($self->has_signature) {
		my @sig = @{ $self->signature };
		while (@sig) {
			shift @sig
				while HashRef->check($sig[0]) && !$sig[0]{slurpy};

			my $name = shift @sig;
			my $type = shift @sig;

			next unless $name =~ /\A[A-Z][A-Z0-9_]*\z/i;

			if (Bool->check($type)) {
				$type = $type ? Any : Optional[Any];
			}

			unless (PERL_NATIVE_ALIASES) {
				require Data::Alias;
			}

			push @code, PERL_NATIVE_ALIASES
				? "\\my \$$name = \\\$_{$name};"
				: "Data::Alias::alias( my \$$name = \$_{$name} );";

			if ($type->is_a_type_of(HashRef)) {
				push @code, PERL_NATIVE_ALIASES
					? "\\my \%$name = \$$name;"
					: "Data::Alias::alias( my \%$name = \%{ \$$name } );";
			}

			if ($type->is_a_type_of(ArrayRef)) {
				push @code, PERL_NATIVE_ALIASES
					? "\\my \@$name = \$$name;"
					: "Data::Alias::alias( my \@$name = \@{ \$$name } );";
			}
		}
	}

	push @code, "#line 1 \"template\"\n";

	my $template = $self->template;
	if ($self->trim) {
		$template =~ s/(?:\A\s*)|(?:\s*\z)//gsm;
	}

	if (my $outdent = $self->outdent) {
		$outdent > 0
			? ($template =~ s/^\s{0,$outdent}//gsm)
			: ($template =~ s/^\s+//gsm);
	}

	my @delims = @{ $self->delimiters };
	my $regexp = join('|', map quotemeta($_), @delims);
	my @parts  = split /($regexp)/, $template;

	my $mode = 'text';
	while (@parts) {

		my $next = shift @parts;

		if ($next eq $delims[0]) {
			$mode = ($mode eq 'text') ? 'code' : confess("Impossible state");
			next;
		}

		if ($next eq $delims[1]) {
			$mode = ($mode eq 'code') ? 'text' : confess("Impossible state");
			next;
		}

		my $terminator = $delims[ ($mode eq 'text') ? 0 : 1 ];
		while (@parts and $parts[0] ne $terminator) {
			$next .= shift(@parts);
		}

		if ($mode eq 'text') {
			$code[-1] .= sprintf('$OUT .= %s;', perlstring($next));
			if ($next =~ /\n/sm) {
				my $count = $next;
				$count = ($count =~ y/\n//);
				$code[-1] .= "\n" x $count;
			}
		}
		elsif ($next =~ /\A=/) {
			my ($indent) = map /\A(\s*)/, grep /\S/, split /\n/, substr($next, 1);
			$code[-1] .= sprintf(
				$self->has_escape ? '$OUT .= $_ESCAPE->(do { %s %s });' : '$OUT .= do { %s %s };',
				sprintf("\$INDENT = %s;", perlstring($indent)),
				substr($next, 1),
			);
		}
		else {
			my ($indent) = map /\A(\s*)/, grep /\S/, split /\n/, $next;
			$code[-1] .= sprintf("\$INDENT = %s; %s;", perlstring($indent), $next);
		}
	}

	if ($self->trim) {
		push @code, '$OUT =~ s/(?:\A\s*)|(?:\s*\z)//gsm;';
	}

	if ($self->has_post_process) {
		push @code, 'do { local *_ = \$OUT; $_POST->($OUT) };';
		$env{'$_POST'} = \ do { $self->post_process };
	}
	else {
		push @code, '$OUT;';
	}

	push @code, '}';

	#warn join "\n", @code, "";
	return (\@code, \%env);
}

sub _lookup_escaping {
	my $style = shift;

	return $style if CodeRef->check($style);

	$style = lc $style;

	if ($style eq 'html') {
		require HTML::Entities;
		return \&HTML::Entities::encode_entities;
	};

	if ($style eq 'xml') {
		require HTML::Entities;
		return \&HTML::Entities::encode_entities_numeric;
	};

	croak "Unsupported escaping style '$style'";
}

1;

__END__