File Coverage

blib/lib/Template/Compiled.pm

Criterion	Covered	Total	%
statement	119	134	88.8
branch	31	48	64.5
condition	5	5	100.0
subroutine	19	24	79.1
pod	2	2	100.0
total	176	213	82.6

use 5.008;
use strict;
use warnings;

package Template::Compiled;

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

use Eval::TypeTiny::CodeAccumulator;
use Types::Standard qw( -types Join );
use Type::Params 2.000000 qw( signature );
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   => !!1,
);

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_sub {
	my $self = shift;

	my $code = 'Eval::TypeTiny::CodeAccumulator'->new(
		description => 'template prelude',
	);

	my $var_escape = $code->add_variable(
		'$_ESCAPE',
		\ ( $self->escape or sub { $_[0] } ),
	);

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

	$code->add_line( 'sub _ ($);' );
	$code->add_line( sprintf( '*_ = sub ($) { goto %s };', $var_escape ) );

	$code->add_line( 'local %_;' );
	$code->add_line( 'my ($OUT, $INDENT) = (q(), q());' );
	$code->add_line( 'our $_OUT_REF = \\$OUT;' );

	if ( PERL_NATIVE_ALIASES ) {
		$code->add_line( 'use feature qw( refaliasing );' );
		$code->add_line( 'no warnings qw( experimental::refaliasing );' );
	}

	my $compiled_signature;
	if ( $self->has_signature ) {
		$compiled_signature = signature(
			want_object => 1,
			named => $self->signature,
			bless => 0,
		);
		my $var_signature = $code->add_variable(
			'$_SIGNATURE',
			\ do { $compiled_signature->coderef->compile },
		);
		$code->add_line( sprintf( '%%_ = %%{ %s->(@_) };', $var_signature ) );
	}
	else {
		$code->add_line( '%_ = (@_==1 and ref($_[0]) eq "HASH") ? %{$_[0]} : @_%2 ? Carp::croak("Expected even-sized list of arguments") : @_;' );
	}

	if ( $compiled_signature ) {
		my @sig = (
			@{ $compiled_signature->parameters },
			$compiled_signature->has_slurpy ? $compiled_signature->slurpy : (),
		);
		while (@sig) {
			my $param = shift @sig;
			my $name  = $param->name;
			my $type  = $param->type;

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

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

			$code->add_line(
				PERL_NATIVE_ALIASES
					? "\\my \$$name = \\\$_{$name};"
					: "Data::Alias::alias( my \$$name = \$_{$name} );"
			);

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

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

	# Break encapsulation!
	push @{ $code->{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[ 0 + ( $mode ne 'text' ) ];
		while ( @parts and $parts[0] ne $terminator ) {
			$next .= shift( @parts );
		}

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

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

	if ( $self->has_post_process ) {
		my $var_post = $code->add_variable(
			'$_POST',
			\ do { $self->post_process },
		);
		$code->add_line( sprintf 'do { local *_ = \$OUT; %s->($OUT) };', $var_post );
	}
	else {
		$code->add_line( '$OUT;' );
	}

	$code->decrease_indent;
	$code->add_line( '}' );

	return $code->compile;
}

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__