#!/usr/bin/perl
# A really simple template engine
# (c) 2004--2008 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;
}

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 {
			die "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 $@;
		die "Error evaluating $x: $@";
	} else {
		return "";
	}
}

sub eval_func($$) {
	my ($f, $a) = @_;
	if ($f =~ /^(if|fi|else|elif)$/) {
		if ($f eq "if") {
			$a ne "()" or die "\@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 die "\@fi takes no arguments";
			$#cond or die "\@fi without \@if";
			shift @cond;
		} elsif ($f eq "else") {
			$a eq "()" or die "\@else takes no arguments";
			$#cond or die "\@else without \@if";
			$cond[0] = -$cond[0];
		} elsif ($f eq "elif") {
			$a ne "()" or die "\@elif requires an argument";
			$#cond or die "\@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) = @_;
	pos $t = 0;
	for(;;) {
		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) {
			die "Unknown control sequence $1";
		} elsif ($t =~ /\G$/cgs) {
			last;
		} elsif ($t =~ /\G([^\n]*)/cgs) {
			die "Internal parser error at $1 (pos " . pos($t) . ")";
		} else { die; }
	}
}

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

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

sub finish()
{
	$#cond and die "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);
	finish();
}

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

package T;

import UCW::Temple;

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;
