File Coverage

blib/lib/Piffle/Template.pm

Criterion	Covered	Total	%
statement	133	160	83.1
branch	28	54	51.8
condition	5	7	71.4
subroutine	21	21	100.0
pod	3	3	100.0
total	190	245	77.5

package Piffle::Template;
use strict;
use base qw{Exporter};
use vars qw{@EXPORT_OK $VERSION $PACKAGE_NUM};
use File::Spec;
use Symbol;
use Carp;
use utf8;
no bytes;

@EXPORT_OK = qw{template_to_perl expand_template};
$VERSION = '0.3.1';


sub __make_package_name
{
	return sprintf("%s::G%05d", __PACKAGE__, ++$PACKAGE_NUM);
}


sub __slurp
{
	my ($file, $rbuf) = @_;
	my $fh = gensym();
	local $/; undef $/;
	open($fh, '<', $file) or croak("open $file: $!");
	$$rbuf = <$fh>;
	close($fh);
}


sub __path_search
{
	my ($item, @inc) = @_;
	foreach my $dir (@inc)
	{
		my $path = File::Spec->catfile($dir, $item);
		return $path if -f $path;
	}
	return undef;
}


sub __make_interpolation
{
	my ($ivar, $itype) = @_;
	if ($itype eq 'raw')
	{
		return ";print join('', ($ivar));\n";
	}
	my $perl_line = '';
	if ($itype eq 'uri')
	{
		$perl_line = qq{
			;print join('', map {
				local \$_ = pack('C*', unpack('C*', \$_));
				s{([^a-zA-Z0-9_.-])}{
					sprintf('%%%02X', ord(\$1))
				}eg;
				\$_;
			} ($ivar));
		};
	}
	else
	{
		$perl_line = qq{
			;print join('', map {
				local \$_ = \$_;
				s{([&"'<>])}{
					sprintf('&#%d;', ord(\$1))
				}eg;
				\$_;
			} ($ivar));
		};
	}
	$perl_line =~ s/\n/\040/gs;
	$perl_line =~ s/\s+/\040/g;
	$perl_line =~ s/^\s*//g;
	$perl_line =~ s/\s*$//g;
	return $perl_line . "\n";
}


sub expand_template
{
	my %opt = @_;

	# Various options
	my ($in_buf, $filename, $errors_to, @inc);
	@inc = @{$opt{include_path} || []};
	$errors_to = $opt{errors_to} || 'die';

	# Pick an input source
	if ($opt{source})
	{
		$in_buf = $opt{source};
		$filename = "AnonString";
	}
	elsif ($opt{source_file})
	{
		my $file = $opt{source_file};
		if (ref $file)
		{
			$filename = "AnonFilehandle";
			local $/; undef $/;
			$in_buf = <$file>;
		}
		else
		{
			__slurp($file, \$in_buf);
			$filename = $file;
		}
	}
	else
	{
		croak "No source: use either 'source' or 'source_text'";
	}

	# Decide on where to stuff the output
	my ($out_buf, $out_fh, $close_out);
	$out_buf = '';
	if ($opt{output_file})
	{
		my $file = $opt{output_file};
		local $/;
		undef $/;
		if (ref $file)
		{
			$out_fh = $file;
		}
		else
		{
			$out_fh = gensym();
			open($out_fh, '>', $file)
			    or croak("open $file: $!");
			$close_out = 1;
		}
	}
	else
	{
		if ($] < 5.008)
		{
			# They'll end up with weirdly-named files in the CWD
			# if we don't give up here.
			croak("Store-and-return is not supported for ".
			      "versions of Perl older than 5.8: you must use " .
			      "\"output_file\" instead. Croaked");
		}
		open($out_fh, '>>', \$out_buf)
		    or croak("open-string failed: $!");
		$close_out = 1;
	}

	if ($opt{reported_filename})
	{
		$filename = $opt{reported_filename};
	}

	# Transform
	my $perl = template_to_perl($in_buf, $filename, @inc);
	my $pkg = __make_package_name();
	my $old_out_fh = select($out_fh);
	eval "package $pkg;\nno strict;\n$perl";
	select($old_out_fh);
	close($out_fh) if $close_out;
	if ($@)
	{
		if (! defined $errors_to)
		{
			# suppress: no-op
		}
		elsif (ref($errors_to))
		{
			if (ref($errors_to) eq 'CODE')
			{
				$errors_to->($@);
			}
			else
			{
				print $errors_to $@;
			}
		}
		else
		{
			die $@;
		}
	}
	return $out_buf; #potentially undef
}


sub expand
{
	my $self = shift;
	goto &expand_template;
}


sub template_to_perl
{
	my ($tmpl, $filename, @inc) = @_;
	$filename =~ m/^(.*)$/;
	$filename = $1;
	$filename =~ s/\"/\"\"/g;
	my $nlines = 1;
	my $perl_script = '';
	pos($tmpl) = 0;
	while ($tmpl =~ m{
		\G (.*?)                     #1: preceding or final plaintext
	        (?: \{ ([\%\$\@] \w+)        #2: scalar interpolation
		       (?:,(\w+))? \}        #3: ... with explicit escaping
		 | \<\?include (\s+.*?) \?\> #4: textual inclusion
		 | \<\?perl (\s+.*?) \?\>    #5: perl blocks
		 | \z
		 )
	}gsxi)
	{
		my $txt = $1;
		my ($ivar, $itype) = ($2, $3);
		my $include = $4;
		my $perl = $5;
		if (defined($txt) && $txt ne '')
		{
			$txt =~ s/([\'\\])/\\$1/gs;
			$perl_script .= "\n#line $nlines";
			$perl_script .= " \"$filename\""
			    if defined $filename;
			$perl_script .= "\n;print '$txt';\n";
			$nlines += ($txt =~ s/\n/\n/g);
		}
		if (defined $ivar)
		{
			$perl_script .= "\n#line $nlines";
			$perl_script .= " \"$filename\""
			    if defined $filename;
			$perl_script .= "\n";

			$itype ||= ',xml';
			$itype =~ s/^,//;
			$itype = lc($itype);
			$perl_script .= __make_interpolation($ivar, $itype);
			$nlines += ($ivar =~ s/\n/\n/g);
		}
		elsif (defined $include)
		{
			my $ifile = $include;
			$ifile =~ s/\s+/\040/sg;
			$ifile =~ s/\s*$//;
			$ifile =~ s/^\s*//;
			my $ipath = __path_search($ifile, @inc);
			if (! $ipath)
			{
				my $msg = "Can't locate \"$ifile\" in "
				  . "include_path (include_path contains: "
				  . join(" ", @inc) . ")";
				carp $msg;
			}
			else
			{
				my $ibuf;
				__slurp($ipath, \$ibuf);
				$perl_script .= template_to_perl
					($ibuf, $ipath, @inc);
			}
			$nlines += ($include =~ s/\n/\n/g);
		}
		elsif (defined $perl)
		{
			#  $perl =~ s/^\040//;
			$perl_script .= "\n#line $nlines";
			$perl_script .= " \"$filename\""
			    if defined $filename;
			$perl_script .= "\n$perl\n";
			$nlines += ($perl =~ s/\n/\n/g);
		}
	}
	return $perl_script;
}

1;