File Coverage

blib/lib/Mock/Data/Template.pm

Criterion	Covered	Total	%
statement	72	75	96.0
branch	37	46	80.4
condition	11	17	64.7
subroutine	17	17	100.0
pod	6	6	100.0
total	143	161	88.8

package Mock::Data::Template;
use strict;
use warnings;
use overload '""' => sub { shift->to_string };
require Carp;
use Mock::Data::Util qw( _parse_context _escape_str );
require Mock::Data::Generator;
our @ISA= qw( Mock::Data::Generator );

# ABSTRACT: Create a generator that plugs other templates into a string
our $VERSION = '0.01'; # VERSION


sub new {
	my $class= shift;
	my %self= (@_ == 1 && !ref $_[0])? ( template => $_[0] )
		: (@_ == 1 && ref $_[0] eq 'HASH')? %{$_[0]}
		: @_ > 1? @_
		: Carp::croak("Invalid constructor arguments to $class");
	# Parse now, to report errors
	$self{_compiled}= $class->parse_template($self{template}, { compile => 1 });
	bless \%self, $class;
}


sub template { shift->{template} }


sub compile {
	my $cmp= $_[0]{_compiled};
	return ref $cmp? $cmp : sub { $cmp };
}

sub generate {
	my $cmp= shift->{_compiled};
	return ref $cmp? $cmp->(@_) : $cmp;
}


sub to_string {
	"template('" . shift->template . "')";
}


sub parse_template {
	my ($self, $str, $flags)= @_;
	local $_= $str;
	pos= 0;
	my $ret;
	local $@;
	defined eval { $ret= _parse_template($flags || {}) }
		or Carp::croak("$@ at "._parse_context);
	return $ret;
}

# Parse a template string in $_ from pos($_)
sub _parse_template {
	my @parts;
	my $outer= !$_[0]{inner};
	local $_[0]{inner}= 1 if $outer;
	while (1) {
		# Consume run of literal characters
		push @parts, $1 if $outer? /\G([^{]+)/gc : /\G([^ \t\{\}]+)/gc;
		# at end of template, or beginning of a reference to something
		last unless /\G(?=\{)/gc;
		push @parts, _parse_template_reference(@_);
	}
	# Combine adjacent scalars in the list
	@parts= grep ref || length, @parts;
	for (my $i= $#parts - 1; $i >= 0; --$i) {
		if (!ref $parts[$i] and !ref $parts[$i+1]) {
			$parts[$i] .= splice(@parts, $i+1, 1);
		}
	}
	if ($_[0]{compile}) {
		return @parts == 1 && !ref $parts[0]? $parts[0]
			: sub { join '', map +(ref? $_->(@_) : $_), @parts }
	} else {
		return \@parts;
	}
}

# Parse one of the curly-brace notations
sub _parse_template_reference {
	if (/\G\{(\w+)/gc) {
		my $generator_name= $1;
		my (@named_param, @pos_param);
		if (/\G[ \t]+/gc) {
			while (!/\G\}/gc) {
				if (/\G(\w+)=/gc) {
					push @named_param, $1, _parse_template(@_);
				} else {
					push @pos_param, _parse_template(@_);
				}
				/\G[ \t]*/gc;
			}
		} else {
			/\G\}/gc or die "Expected '}'";
		}
		if ($_[0]{compile}) {
			# compile by making a list of which params are function calls, and update lists for only those positions
			my @named_literal= @named_param;
			my @dynamic_named= grep ref $named_param[$_], 0 .. $#named_param;
			my @pos_literal= @pos_param;
			my @dynamic_pos= grep ref $pos_literal[$_], 0 .. $#pos_param;
			if (@named_param) {
				return sub {
					$named_literal[$_]= $named_param[$_]->(@_) for @dynamic_named;
					$pos_literal[$_]= $pos_param[$_]->(@_) for @dynamic_pos;
					$_[0]->call($generator_name, { @named_literal }, @pos_literal);
				}
			} else {
				return sub {
					$pos_literal[$_]= $pos_param[$_]->(@_) for @dynamic_pos;
					$_[0]->call($generator_name, @pos_literal);
				}
			}
		} else {
			return [ $generator_name, (@named_param? { @named_param }:()), @pos_param ];
		}
	}
	return chr hex $1 if /\G\{ [#] ([0-9A-Za-z]+) \}/xgc;
	return '' if /\G\{\}/xgc;
	die "Invalid template notation\n";
}

1;

__END__