#
# Copyright 1998 by J. Zobel. It may be distributed and modified under 
# the same terms as perl itself. As usual there are no warranties. If this
# innocent looking piece of code does anything harmful or nothing at all
# i am not responsible. If this module does not do what you expect:
# 'Use the source, Luke'
#
# nc-zobeljo@netcologne.de
# 

package Interpolate;
 
$VERSION	= '0.3';

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(interpolate read_tmpl);

use integer;
use strict;

#
# To be adapted 
#

my($block_begin)	= '@+';
my($block_end)		= '@-';
my($block_var)		= '$';
my($block_br_open)	= '{';
my($block_br_close)	= '}';
my($block_br_iffi)	= '?';
my($block_br_else)	= ':';

#
# End of changeable section
#

#expansion markers
my($regx_begin)	= quotemeta($block_begin);
my($regx_end)	= quotemeta($block_end);
my($regx_var)	= quotemeta($block_var);
my($regx_br_open)	= quotemeta($block_br_open);
my($regx_br_close)	= quotemeta($block_br_close);
my($regx_br_iffi)	= quotemeta($block_br_iffi);
my($regx_br_else)	= quotemeta($block_br_else);

# \?\{
my($regx_if)		= quotemeta($block_br_iffi.$block_br_open);
# \}\:\{
my($regx_else)		= quotemeta($block_br_close.$block_br_else.$block_br_open);
# \}\?
my($regx_fi)		= quotemeta($block_br_close.$block_br_iffi);

#size of unescaped expansion markers (as found in tmpl)                         
my($sz_block_begin)	= length($block_begin);
my($sz_block_var)	= length($block_var);

my($rest_inter)	= "(?:$regx_begin\\w+)*(?:$regx_end\\w+|$regx_var(?:\\w+|\\#))";                                            
sub rest_bool
{
	my($off)	= @_;
	my($off_p)	= $off+1;
	return "(?:$regx_br_iffi(\\d+)$regx_br_open.*?
				(?:$regx_br_close\\$off$regx_br_iffi
				|$regx_br_close\\$off$regx_br_else(\\d+)$regx_br_open.*?
				$regx_br_close\\$off_p$regx_br_iffi
				)
			)?";
}

my($rest_bool_3)	= rest_bool(3);
my($rest_bool_7)	= rest_bool(7);

# splitting for interpolate                                 
# (	 (\@\+\w+)(?:\@\+\w+)*(?:\@\-\w+|\$\w+)(?:.*\2(?:\@\+\w+)*(?:\@\-\w+|\$\w+))*
# 1  2                                                  
#    (?:\?(d+)\{.*?(?:\}\3\?
#         3         
#                  |\}\3\:(d+)\{.*?\}\4\?
#                         4
#                  )
#    )?
# )
# | 
# ( (\@\-\w+)(?:.*\6)*
# 5 6
#   (?:\?(d+)\{.*?(?:\}\7\?
#        7
#                 |\}\7\:(d+)\{.*?\}\8\?
#                        8
#                 )
#   )?
# )
#			1	2			
#my($split_inter)= "	(	($regx_begin\\w+)$rest_inter$rest_bool_3(?:.*\\2$rest_inter$rest_bool_5)*)\
#			|	(	($regx_end\\w+)(?:.*\\8$rest_bool_9)*)";

#		(	(\@\+\w+)(?:\@\+\w+)*(?:\@\-\w+|\$\w+)
#				(?:\?(d+)\{.*?
#				(?:\}\3\?
#				|\}\3\:(d+)\{.*?
#				\}\4\?
#				)
#				)? 
#		)
#	|	(	(\@\-\w+)
#				(?:\?(d+)\{.*?
#				(?:\}\7\?
#				|\}\7\:(d+)\{.*?
#				\}\8\?
#				)
#				)?
#		)

my($split_inter)= "	(	($regx_begin\\w+)$rest_inter$rest_bool_3 )
				|	(	($regx_end\\w+)$rest_bool_7)";
#				|	(	($regx_end\\w+)$rest_inter$rest_bool_6)";

#
#	1	=>	2, 3
#	4	=>	5, 6
#
#	d.h. %7
#
#	$cur_b_begin, $cur_b_end
#   $cur_recurse
#

#
#name:		interpolate	
#param.:	\$tmpl
#			%ipl	
#return:	!=0 indicates error 
#
# The template in $tmpl is expanded using the values in %ipl
#

sub interpolate
{
	my($reftmpl,%ipl) = @_;	

	my($err_enum)	= enumerate_brackets($reftmpl);
	if ($err_enum) {	
		return $err_enum;
	}

	return rcr_interpolate($reftmpl, 0, %ipl);
}

#
#name:		rcr_interpolate	
#param.:	\$tmpl
#      		$c_r
#	    	%ipl	
#return:	!=0 indicates error 
#
# Does the work for interpolate by calling itself recursively 
#

sub rcr_interpolate
{
	my($reftmpl, $c_r, %ipl) = @_;	
	my($rtn);

	my($match)	= 0;

	$ipl{'#'}	= $c_r;
	#
	# replace $name?{x_if}:{x_else}?, but not @+bname$name?{..}?
	#
	while ($$reftmpl =~ s/(	   ((?:$regx_begin\w+)*)$regx_var(\w+|\#)
						# 1    2                             3
								(\?(\d+)\{(.*?)(?:\}\5\?
						#       4  5      6 
												|\}\5\:(\d+)\{(.*?)\}\7\?
						#                              7      8
												)
								)?
							)	
				/($2 ne '')?$1:((($match=1),$4)?(($ipl{$3})?$6:$8):$ipl{$3})/gosex
			&&	$match)
	{
		$match	= 0;
	}

	#
	# split $$reftmpl into blocks
	#
	my(@texts)	= ();
	my(@recurses)	= ();
	my(@blocknames)	= ();
	my(@seperators)	= ();
	$rtn	= split_blocks($reftmpl,\@texts, \@recurses, \@blocknames, \@seperators, $split_inter);
	if ($rtn > 0)
	{
		return $rtn;
	} 
	elsif ($rtn == -1)
	{
		# nothing else to do
		return 0;
	}

	#
	# recursion on @recurses
	#
	my($cnt)	= 0;
	my(@result)	= ();
	my($tmpl_next);
	foreach $tmpl_next (@recurses)
	{   
		#             
		# prepare recursion     
		#
		my($loc_name)	= $blocknames[$cnt];
		remove_blockname(\$tmpl_next, $loc_name);

		#
		#do recursion
		#
		my(@ipl_all)	= @{$ipl{$loc_name}};                   

		# if @ipl_all is empty, there is no sensible expansion
		return 3 if @ipl_all == 0;

		my(@tmpl_expanded)	= ();
		my $ipl_next;
		# The index for $#
		my $cnt_r	= 0;
		foreach $ipl_next (@ipl_all)
		{
			my($new_item) = $tmpl_next; 

			my($rtn)	= rcr_interpolate(\$new_item, $cnt_r, %{$ipl_next}); 
			if ($rtn)
			{
				return $rtn;
			}

			push(@tmpl_expanded, $new_item);

			$cnt_r++;
		}    

		push(@result,$texts[$cnt]);                        
		push(@result,join($seperators[$cnt],@tmpl_expanded));
		
		$cnt++;
	}	

	push(@result,$texts[$cnt]);

	$$reftmpl	= join('',@result);

	# Ok             
	return 0;
}

#
#name:		data
#param.:	$tmpl
#			\%ipl	
#return:	!=0 indicates error 
#
# Does the work for interpolate by calling itself recursively 
#

sub data
{
	my($tmpl,$refipl) = @_;	
	my($rtn);

	#
	# find $name, but not @+bname$name
	#
	$tmpl =~	s/(((?:$regx_begin\w+)*)$regx_var(\w+))
				 /($2 eq '')?($$refipl{$3}=undef,''):$1/goex;

	#
	# split $tmpl into blocks
	#
	my(@texts)	= ();
	my(@recurses)	= ();
	my(@blocknames)	= ();
	my(@seperators)	= ();
	$rtn	= split_blocks(\$tmpl,\@texts, \@recurses, \@blocknames, \@seperators, $split_inter);
	if ($rtn > 0)
	{
		return $rtn;
	} 
	elsif ($rtn == -1)
	{
		# nothing else to do
		return 0;
	}

	#
	# recursion on @recurses
	#
	my($cnt)	= 0;
	my(@result)	= ();
	my($tmpl_next);
	foreach $tmpl_next (@recurses)
	{   
		#             
		# prepare recursion     
		#
		my($locname)	= $blocknames[$cnt];
		remove_blockname(\$tmpl_next, $locname);

		#
		#do recursion
		#
		my($refipl_next)	= {};
		$$refipl{$locname}	= [$refipl_next];                  

		my($rtn)	= data($tmpl_next, $refipl_next); 
		if ($rtn)
		{
			return $rtn;
		}

		$cnt++;
	}	

	# Ok             
	return 0;
}


#
#name:		remove_blockname
#param.:	\$recurse
#		$blockname
#return:	0
#
# in $recurse @+blockname is removed
#

sub remove_blockname
{
	my($refrecurse,$blockname) = @_;

	$$refrecurse =~ s/$regx_begin$blockname($rest_inter)/$1/g;
	return 0;
}

#
#name:		split_blocks
#param.:	\$tmpl 
#		\@texts
#		\@recurses
#		\@blocknames
#		\@seperators
#		$split
#
#return:	>0 => error
#
# $tmpl is split one level according to
# $text^$recurse^$seperator^@-bname..@-bname^$text^....
# where $recurse is @+bname..@+bname
# using the regular xpression in $split

sub split_blocks
{
	my($reftmpl, $reftext, $refrecurse, $refblockname, $refseperator, $split) = @_;


	#
	#search for blocks
	#               
	my(@f_list)	= split(/$split/sgox, $$reftmpl);

#print "Laenge: ".scalar(@f_list)."\n";
		
	if (@f_list == 1)
	{                
		# only one block, nothing more to do
		return -1;
	}

	# sort @f_list into @texts, @blocknames, @recurses, @seperators 
	# and check for consistency
	my($cnt)	= 0;
	my(@texts)	= ();
	my(@recurses)	= ();
	my(@blocknames)	= ();
	my(@seperators)	= ();
	my($last_text)	= '';
	my($last_recurse)	= '';
	my($last_blockname)	= '';
	my($last_blocktype)	= '';
	my($cur_blocktype)	= '';
	my($allow_blockname_change)	= 0;
	my($f_entry);
	foreach $f_entry (@f_list)
	{
		if ($cnt == 0) 	
		{
			$last_text	= $f_entry;
		}
		if ($cnt == 1) 	
		{
			# defined is for perl 5.00x,
			# ne '' is for perl 5.6
			if (defined($f_entry) && $f_entry ne '')
			{
				$cur_blocktype	= '+';
				
				if ($last_blocktype ne '+')
				{
					push(@texts,$last_text);
					$last_recurse	= $f_entry;
					$allow_blockname_change	= 1;
				}
				else
				{
					$last_recurse	= $last_recurse.$last_text.$f_entry;
				}
				$last_blocktype	= '+';
			}
			else
			{
				$cur_blocktype	= '-';
			}
		}
		if (($cnt == 2) && ($cur_blocktype eq '+')) 	
		{
			if ($allow_blockname_change)
			{
				$last_blockname	= substr($f_entry,$sz_block_begin);
				push(@blocknames, $last_blockname);
				$allow_blockname_change	= 0;
			}
			else
			{
				if ($last_blockname	ne substr($f_entry,$sz_block_begin))
				{
					return 1;
				}
			}
		}
		# 3, 4 is bracket enumeration
		if ($cnt == 5) 	
		{
			if (defined($f_entry) && $f_entry ne '')
			{
				if ($cur_blocktype	ne '-')
				{
					return 4;
				}

				if ($last_blocktype ne '-')
				{
					push(@seperators,$last_text);
					push(@recurses,$last_recurse);
				}
				$last_blocktype	= '-';
			}
			else
			{
				if ($cur_blocktype	ne '+')
				{
					return 5;
				}			
			}
		}
		if (($cnt == 6) && ($cur_blocktype eq '-')) 	
		{
			if ($last_blockname	ne substr($f_entry,$sz_block_begin))
			{
				return 2;
			}
		}
		# 7, 8 is bracket enumeration
		if ($cnt == 8)	{$cnt = -1;}

		$cnt++;
	}

	push(@texts,$last_text);
	if ($last_blocktype ne '-')
	{
		return 6;
	}
	
	@$reftext	= @texts;
	@$refrecurse	= @recurses;
	@$refblockname	= @blocknames;
	@$refseperator	= @seperators;

	return 0;
}

#
#name:		get_enum
#param.:	$r1, $r2, $r3 - matches in enumerate_brackets
#			$rg	- globals aus enumerate_brackets
#
#return:    the enumerated bracket	
#
# Matching brackets are enumerated  
#

sub get_enum {
	my($r1, $r2, $r3, $rg)	= @_;
	my($num_brack_close)	= 0;
	if ($r2 || $r3) {
		$num_brack_close	= pop(@{$rg->{'stack_open'}});
		if (!$num_brack_close) {
			$rg->{'err_brack'}	=  1;
			$num_brack_close	= 'NO MATCH';
		}
	}

	if ($r1 || $r2) {
		$rg->{'num_brack'}++;
		push(@{$rg->{'stack_open'}}, $rg->{'num_brack'});	
	} 

	if ($r1) {
		return $block_br_iffi.$rg->{'num_brack'}.$block_br_open;
	} 
	elsif ($r2) {
		return $block_br_close.$num_brack_close.$block_br_else.$rg->{'num_brack'}.$block_br_open;
	}
	elsif ($r3) {
		return $block_br_close.$num_brack_close.$block_br_iffi;
	}
}

#
#name:		enumerate_brackets
#param.:	\$tmpl 
#
#return:	>0 => error
#
# Matching brackets are enumerated  
#

sub enumerate_brackets
{
	my($reftmpl)	= @_;

	my %globals	= (
		'num_brack'	=> 0,
		'err_brack'	=> 0,
		'stack_open'	=> [],
	);
		
	$$reftmpl =~ s/($regx_if)|($regx_else)|($regx_fi)
				  /&get_enum($1, $2, $3, \%globals)/goex;
		
	return $globals{'err_brack'};
}

#
#name:		regx_escape	
#param.:	the string to be escaped
#	
#return:	the escaped string
#
# Escape strings for use in regular expressions
#

# Now using quotemeta
#sub regx_escape
#{
#	my($str)	= @_;
#	$str =~ s/([@+-?\$\{\}])/\\$1/g;

#	return $str;
#}


#
#name:		read_tmpl	
#param.:	the name of the template file
#	
#return:	the content of the template file
#
# Frequenly needed helper function
#
sub read_tmpl
{
	my $f_tmpl	= shift;
	my $tmpl	= '';

	open(TMPL, $f_tmpl)
	or die "Could not open $f_tmpl:$!";
	read(TMPL, $tmpl, -s TMPL);
	close(TMPL);

	return $tmpl;
}

1;