# A really simple template engine
# (c) 2004--2012 Martin Mares <mj@ucw.cz>

package UCW::Temple;

use strict;
use warnings;
no strict 'vars';

require Exporter;
our $VERSION = 1.0;
our @ISA = qw(Exporter);
our @EXPORT = qw(out);
our @EXPORT_OK = qw();

use IO::File;

our $arguments;
our @cond;

sub out {
	$T::out_func->(@_);
	return;
}

our %deps = ();

sub add_depend($) {
	$deps{$_[0]} = 1;
}

my $current_file_name;
my $current_string;
my $current_pos;

sub error($;$) {
	my ($msg, $offset) = @_;
	if (defined $current_file_name) {
		#
		#  This is rather tricky. We want to report the exact place, where the error
		#  occurred, but the cost of keeping track of the current line number is too high.
		#  Hence we keep just the current position inside the input stream and convert
		#  it to the line number only when reporting an error.
		#
		my $input = substr(${$current_string}, 0, $current_pos);
		my @newlines = ($input =~ m{\n}g);
		my $line = @newlines + ($offset // 1);
		die "$current_file_name:$line: $msg\n";
	} else {
		die "$msg\n";
	}
}

sub get_nested($$$) {
	my ($r, $left, $right) = @_;
	pos $$r = pos($$r) - 1;
	my $z = "";
	my $nest = 0;
	do {
		if ($$r =~ /\G([^$left$right]+)/cgs) {
		} elsif ($$r =~ /\G([$left])/cgs) {
			$nest++;
		} elsif ($$r =~ /\G([$right])/cgs) {
			$nest--;
		} else {
			error "File ended when looking for matching $right";
		}
		$z .= $1;
	} while ($nest);
	return $z;
}

sub eval_if_ok($) {
	if ($cond[0] > 0) {
		my $x = shift;
		my $res = eval "package T; $x";
		return $res unless $@;
		my $m = $@;
		chomp $m;
		if (my ($msg, $line) = $m =~ m{(.*) at \(eval \d+\) line (\d+)\.$}) {
			error $msg, $line;
		} else {
			error $m;
		}
	} else {
		return "";
	}
}

sub eval_func($$) {
	my ($f, $a) = @_;
	if ($f =~ /^(if|fi|else|elif)$/) {
		if ($f eq "if") {
			$a ne "()" or error "\@if requires an argument";
			if ($cond[0] > 0) {
				unshift @cond, (eval_if_ok($a) ? 1 : -1);
			} else {
				unshift @cond, 0;
			}
		} elsif ($f eq "fi") {
			$a eq "()" or error "\@fi takes no arguments";
			$#cond or error "\@fi without \@if";
			shift @cond;
		} elsif ($f eq "else") {
			$a eq "()" or error "\@else takes no arguments";
			$#cond or error "\@else without \@if";
			$cond[0] = -$cond[0];
		} elsif ($f eq "elif") {
			$a ne "()" or error "\@elif requires an argument";
			$#cond or error "\@elif without \@if";
			if ($cond[0] > 0) {
				$cond[0] = 0;
			} elsif ($cond[0] < 0) {
				$cond[0] = 1;
				$cond[0] = (eval_if_ok($a) ? 1 : -1);
			}
		}
		# print "Cond stack: @cond\n";
	} else {
		my $res = eval_if_ok("$f $a");
		out $res if defined $res;
	}
}

sub parse_string($$) {
	my ($t, $name) = @_;
	my ($old_fn, $old_str, $old_pos) = ($current_file_name, $current_string, $current_pos);
	$current_file_name = $name;
	$current_string = \$t;
	pos $t = 0;
	for (;;) {
		$current_pos = pos $t;
		if ($t =~ /\G([^\@]+)/cgs) {
			out $1 if $cond[0] > 0;
		} elsif ($t =~ /\G\@\s*\n/cgs) {
			# @ at end of line is ignored and eats the end of line
		} elsif ($t =~ /\G\@#[^\n]*\n/cgs) {
			# a comment, which is ignored
		} elsif ($t =~ /\G\@\@/cgs) {
			out "\@" if $cond[0] > 0;
		} elsif ($t =~ /\G\@{/cgs) {
			my $x = get_nested(\$t, "{", "}");
			out eval_if_ok($x);
		} elsif ($t =~ /\G\@\[/cgs) {
			my $x = get_nested(\$t, '\[', '\]');
			$x =~ s/^\[//;
			$x =~ s/\]$//;
			eval_if_ok($x);
		} elsif ($t =~ /\G\@\(/cgs) {
			my $x = get_nested(\$t, '\(', '\)');
			$x =~ s/^\(//;
			$x =~ s/\)$//;
			out (defined($arguments->{$x}) ? $arguments->{$x} : "");
		} elsif ($t =~ /\G\@(\w+)\(/cgs) {
			my $func = $1;
			my $args = get_nested(\$t, '(', ')');
			eval_func($func, $args);
		} elsif ($t =~ /\G\@(\w+)([^\n]*)\n/cgs) {
			eval_func($1, "($2)");
		} elsif ($t =~ /\G\@(\$\w+)/cgs) {
			out eval_if_ok($1);
		} elsif ($t =~ /\G(\@[^\n]*)/cgs) {
			error "Unknown control sequence $1";
		} elsif ($t =~ /\G$/cgs) {
			last;
		} elsif ($t =~ /\G([^\n]*)/cgs) {
			error "Internal parser error";
		} else { die; }
	}
	($current_file_name, $current_string, $current_pos) = ($old_fn, $old_str, $old_pos);
}

sub parse_file($) {
	my ($name) = @_;
	add_depend($name);
	my $fh = new IO::File $name;
	error "Unable to open $name: $!" unless defined $fh;
	my $text;
	{ local $/; undef $/; $text = <$fh>; }
	undef $fh;
	parse_string($text, $name);
}

sub start(;$) {
	$arguments = $_[0];
	@cond = (1);
}

sub finish() {
	$#cond and error "Unterminated \@if (depth $#cond)";
}

sub process_file($;$) {
	my ($name, $args) = @_;
	start($args);
	parse_file($name);
	finish();
}

sub process_string($;$) {
	my ($string, $args) = @_;
	start($args);
	parse_string($string, '<string>');
	finish();
}

### Perl commands embedded in the templates are evaluated in this package ###

package T;

import UCW::Temple;

# Beware: Functions in the T package should report errors via die(), not error().

our $temp;
our $out_func = sub { print @_; };

sub include {
	my $fn = shift @_;
	while (@_) {
		my $v = shift @_;
		$temp = shift @_;
		UCW::Temple::eval_if_ok("\$$v = \$temp");
	}
	UCW::Temple::parse_file($fn);
	return;
}

sub load {
	my $f = shift @_;
	(!defined($f) || @_) and die "\@load requires only one argument";
	UCW::Temple::add_depend($f);
	require $f;
	return;
}

1;
