File Coverage

blib/lib/Template/Simple.pm

Criterion	Covered	Total	%
statement	192	196	97.9
branch	43	54	79.6
condition	6	7	85.7
subroutine	33	34	97.0
pod	6	6	100.0
total	280	297	94.2

package Template::Simple ;

use warnings ;
use strict ;

use Carp ;
use Data::Dumper ;
use Scalar::Util qw( reftype blessed ) ;
use File::Slurp ;

our $VERSION = '0.06';

my %opt_defaults = (

	pre_delim	=> qr/\[%/,
	post_delim	=> qr/%\]/,
	token_re	=> qr/\w+?/,
	greedy_chunk	=> 0,
#	upper_case	=> 0,
#	lower_case	=> 0,
	search_dirs	=> [ qw( templates ) ],
) ;

sub new {

	my( $class, %opts ) = @_ ;

	my $self = bless {}, $class ;

# get all the options or defaults into the object

# support the old name 'include_paths' ;

	$opts{search_dirs} ||= delete $opts{include_paths} ;

	while( my( $name, $default ) = each %opt_defaults ) {

		$self->{$name} = defined( $opts{$name} ) ?
				$opts{$name} : $default ;
	}

	croak "search_dirs is not an ARRAY reference" unless
		ref $self->{search_dirs} eq 'ARRAY' ;

# make up the regexes to parse the markup from templates

# this matches scalar markups and grabs the name

	$self->{scalar_re} = qr{
		$self->{pre_delim}
		\s*			# optional leading whitespace
		($self->{token_re})	# grab scalar name
		\s*			# optional trailing whitespace
		$self->{post_delim}
	}xi ;				# case insensitive

#print "RE <$self->{scalar_re}>\n" ;

# this grabs the body of a chunk in either greedy or non-greedy modes

	my $chunk_body = $self->{greedy_chunk} ? qr/.+/s : qr/.+?/s ;

# this matches a marked chunk and grabs its name and text body

	$self->{chunk_re} = qr{
		$self->{pre_delim}
		\s*			# optional leading whitespace
		START			# required START token
		\s+			# required whitespace
		($self->{token_re})	# grab the chunk name
		\s*			# optional trailing whitespace
		$self->{post_delim}
		($chunk_body)		# grab the chunk body
		$self->{pre_delim}
		\s*			# optional leading whitespace
		END			# required END token
		\s+			# required whitespace
		\1			# match the grabbed chunk name
		\s*			# optional trailing whitespace
		$self->{post_delim}
	}xi ;				# case insensitive

#print "RE <$self->{chunk_re}>\n" ;

# this matches a include markup and grabs its template name

	$self->{include_re} = qr{
		$self->{pre_delim}
		\s*			# optional leading whitespace
		INCLUDE			# required INCLUDE token
		\s+			# required whitespace
		($self->{token_re})	# grab the included template name
		\s*			# optional trailing whitespace
		$self->{post_delim}
	}xi ;				# case insensitive

# load in any templates

	$self->add_templates( $opts{templates} ) ;

	return $self ;
}

sub compile {

	my( $self, $template_name ) = @_ ;

	my $tmpl_ref = eval {
		 $self->_get_template( $template_name ) ;
	} ;

#print Dumper $self ;

	croak "Template::Simple $@" if $@ ;

	my $included = $self->_render_includes( $tmpl_ref ) ;

# compile a copy of the template as it will be destroyed

	my $code_body = $self->_compile_chunk( '', "${$included}", "\t" ) ;

	my $source = <
no warnings ;

sub {
	my( \$data ) = \@_ ;

	my \$out ;

	use Scalar::Util qw( reftype ) ;

$code_body
	return \\\$out ;
}
CODE

#print $source ;

	my $code_ref = eval $source ;

#print $@ if $@ ;

	$self->{compiled_cache}{$template_name} = $code_ref ;
	$self->{source_cache}{$template_name} = $source ;
}

sub _compile_chunk {

	my( $self, $chunk_name, $template, $indent ) = @_ ;

	return '' unless length $template ;

# generate a lookup in data for this chunk name (unless it is the top
# level). this descends down the data tree during rendering

	my $data_init = $chunk_name ? "\$data->{$chunk_name}" : '$data' ;

	my $code = <
${indent}my \@data = $data_init ;
${indent}while( \@data ) {

${indent}	my \$data = shift \@data ;
${indent}	if ( reftype \$data eq 'ARRAY' ) {
${indent}		push \@data, \@{\$data} ;
${indent}		next ;
${indent}	}

CODE

	$indent .= "\t" ;

# loop all nested chunks and the text separating them

	while( my( $parsed_name, $parsed_body ) =
		$template =~ m{$self->{chunk_re}} ) {

		my $chunk_left_index = $-[0] ;
		my $chunk_right_index = $+[0] ;

# get the pre-match text and compile its scalars and text. append to the code

		$code .= $self->_compile_scalars(
			substr( $template, 0, $chunk_left_index ), $indent ) ;

# print "CHUNK: [$1] BODY [$2]\n\n" ;
# print "TRUNC: [", substr( $template, 0, $chunk_right_index ), "]\n\n" ;
# print "PRE: [", substr( $template, 0, $chunk_left_index ), "]\n\n" ;

# chop off the pre-match and the chunk

		substr( $template, 0, $chunk_right_index, '' ) ;

# print "REMAIN: [$template]\n\n" ;

# compile the nested chunk and append to the code

		$code .= $self->_compile_chunk(
				$parsed_name, $parsed_body, $indent
		) ;
	}

# compile trailing text for scalars and append to the code

	$code .= $self->_compile_scalars( $template, $indent ) ;

	chop $indent ;

# now we end the loop for this chunk
	$code .= <
$indent}
CODE

	return $code ;
}

sub _compile_scalars {

	my( $self, $template, $indent ) = @_ ;

# if the template is empty return no parts

	return '' unless length $template ;

	my @parts ;

	while( $template =~ m{$self->{scalar_re}}g ) {

# get the pre-match text before the scalar markup and generate code to
# access the scalar

		push( @parts,
			_dump_text( substr( $template, 0, $-[0] ) ),
			"\$data->{$1}"
		) ;

# truncate the matched text so the next match starts at begining of string

		substr( $template, 0, $+[0], '' ) ;
	}

# keep any trailing text part

	push @parts, _dump_text( $template ) ;

	my $parts_code = join( "\n$indent.\n$indent", @parts ) ;

	return <

${indent}\$out .= reftype \$data ne 'HASH' ? \$data :
${indent}$parts_code ;

CODE
}


# internal sub to dump text for the template compiler.  the output is
# a legal perl double quoted string without any leading text before
# the opening " and no trailing newline or ;

sub _dump_text {

	my( $text ) = @_ ;

	return unless length $text ;

	local( $Data::Dumper::Useqq ) = 1 ;

	my $dumped = Dumper $text ;

	$dumped =~ s/^[^"]+// ;
	$dumped =~ s/;\n$// ;

	return $dumped ;
}

sub get_source {

	my( $self, $template_name ) = @_ ;

	return $self->{source_cache}{$template_name} ;
}

sub render {

	my( $self, $template_name, $data ) = @_ ;

	my $tmpl_ref = ref $template_name eq 'SCALAR' ? $template_name : '' ;

	unless( $tmpl_ref ) {

# render with cached code and return if we precompiled this template

		if ( my $compiled = $self->{compiled_cache}{$template_name} ) {

			return $compiled->($data) ;
		}

# not compiled so try to get this template by name or
# assume the template name are is the actual template

		$tmpl_ref =
			eval{ $self->_get_template( $template_name ) } ||
			\$template_name ;
	}

	my $rendered = $self->_render_includes( $tmpl_ref ) ;

#print "INC EXP <$rendered>\n" ;

	$rendered = eval {
		 $self->_render_chunk( $rendered, $data ) ;
	} ;

	croak "Template::Simple $@" if $@ ;

	return $rendered ;
}

sub _render_includes {

	my( $self, $tmpl_ref ) = @_ ;

# make a copy of the initial template so we can render it.

	my $rendered = ${$tmpl_ref} ;

# loop until we can render no more include markups

	1 while $rendered =~
		 s{$self->{include_re}}{ ${ $self->_get_template($1) }}e ;

	return \$rendered ;
}

my %renderers = (

	SCALAR	=> sub { return $_[2] },
	''	=> sub { return \$_[2] },
	HASH	=> \&_render_hash,
	ARRAY	=> \&_render_array,
	CODE	=> \&_render_code,
# if no ref then data is a scalar so replace the template with just the data
) ;


sub _render_chunk {

	my( $self, $tmpl_ref, $data ) = @_ ;

#print "T ref [$tmpl_ref] [$$tmpl_ref]\n" ;
#print "CHUNK ref [$tmpl_ref] TMPL\n<$$tmpl_ref>\n" ;

#print Dumper $data ;

	return \'' unless defined $data ;

# get the type of this data. handle blessed types

	my $reftype = blessed( $data ) ;

#print "REF $reftype\n" ;

# handle the case of a qr// which blessed returns as Regexp

	if ( $reftype ) {

		$reftype = reftype $data unless $reftype eq 'Regexp' ;
	}
	else {
		$reftype = ref $data ;
	}

#print "REF2 $reftype\n" ;

# now render this chunk based on the type of data

	my $renderer = $renderers{ $reftype || ''} ;

#print "EXP $renderer\nREF $reftype\n" ;

	croak "unknown template data type '$data'\n" unless defined $renderer ;

	return $self->$renderer( $tmpl_ref, $data ) ;
}

sub _render_hash {

	my( $self, $tmpl_ref, $href ) = @_ ;

	return $tmpl_ref unless keys %{$href} ;

# we need a local copy of the template to render

	my $rendered = ${$tmpl_ref}	 ;

# recursively render all top level chunks in this chunk

	$rendered =~ s{$self->{chunk_re}}
		      {
			# print "CHUNK $1\nBODY\n----\n<$2>\n\n------\n" ;
#			print "CHUNK $1\nBODY\n----\n<$2>\n\n------\n" ;
#			print "pre CHUNK [$`]\n" ;
			${ $self->_render_chunk( \"$2", $href->{$1} ) }
		      }gex ;

# now render scalars

#print "HREF: ", Dumper $href ;

	$rendered =~ s{$self->{scalar_re}}
		      {
			 # print "SCALAR $1 VAL $href->{$1}\n" ;
			 defined $href->{$1} ? $href->{$1} : ''
		      }ge ;

#print "HASH REND3\n<$rendered>\n" ;

	return \$rendered ;
}

sub _render_array {

	my( $self, $tmpl_ref, $aref ) = @_ ;

# render this $tmpl_ref for each element of the aref and join them

	my $rendered ;

#print "AREF: ", Dumper $aref ;

	$rendered .= ${$self->_render_chunk( $tmpl_ref, $_ )} for @{$aref} ;

	return \$rendered ;
}

sub _render_code {

	my( $self, $tmpl_ref, $cref ) = @_ ;

	my $rendered = $cref->( $tmpl_ref ) ;

	croak <
data callback to code didn't return a scalar or scalar reference
DIE

	return $rendered ;
}

sub add_templates {

	my( $self, $tmpls ) = @_ ;

#print Dumper $tmpls ;
	return unless defined $tmpls ;

 	ref $tmpls eq 'HASH' or croak "templates argument is not a hash ref" ;

# copy all the templates from the arg hash and force the values to be
# scalar refs

	while( my( $name, $tmpl ) = each %{$tmpls} ) {

		defined $tmpl or croak "undefined template value for '$name'" ;

# cache the a scalar ref of the template

		$self->{tmpl_cache}{$name} = ref $tmpl eq 'SCALAR' ?
			\"${$tmpl}" : \"$tmpl"
	}

#print Dumper $self->{tmpl_cache} ;

	return ;
}

sub delete_templates {

	my( $self, @names ) = @_ ;

# delete all the cached stuff or just the names passed in

	@names = keys %{$self->{tmpl_cache}} unless @names ;

#print "NAMES @names\n" ;
# clear out all the caches
# TODO: reorg these into a hash per name

	delete @{$self->{tmpl_cache}}{ @names } ;
	delete @{$self->{compiled_cache}}{ @names } ;
	delete @{$self->{source_cache}}{ @names } ;

# also remove where we found it to force a fresh search

	delete @{$self->{template_paths}}{ @names } ;

	return ;
}

sub _get_template {

	my( $self, $tmpl_name ) = @_ ;

#print "INC $tmpl_name\n" ;

	my $tmpls = $self->{tmpl_cache} ;

# get the template from the cache and send it back if it was found there

	my $template = $tmpls->{ $tmpl_name } ;
	return $template if $template ;

# not found, so find, slurp in and cache the template

	$template = $self->_find_template( $tmpl_name ) ;
	$tmpls->{ $tmpl_name } = $template ;

	return $template ;
}

sub _find_template {

	my( $self, $tmpl_name ) = @_ ;

#print "FIND $tmpl_name\n" ;
	foreach my $dir ( @{$self->{search_dirs}} ) {

		my $tmpl_path = "$dir/$tmpl_name.tmpl" ;

#print "PATH: $tmpl_path\n" ;

		next if $tmpl_path =~ /\n/ ;
		next unless -r $tmpl_path ;

# cache the path to this template

		$self->{template_paths}{$tmpl_name} = $tmpl_path ;

# slurp in the template file and return it as a scalar ref

#print "FOUND $tmpl_name\n" ;

		return read_file( $tmpl_path, scalar_ref => 1 ) ;
	}

#print "CAN'T FIND $tmpl_name\n" ;

	croak <
can't find template '$tmpl_name' in '@{$self->{search_dirs}}'
DIE

}

1; # End of Template::Simple

__END__