File Coverage

blib/lib/HCKit/Template.pm

Criterion	Covered	Total	%
statement	40	435	9.2
branch	0	154	0.0
condition	1	44	2.2
subroutine	7	60	11.6
pod	8	49	16.3
total	56	742	7.5

package HCKit::Template;

use strict;
use warnings;

require Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
@ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use HCKit::Template ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
%EXPORT_TAGS = ();
@EXPORT_OK = ();
@EXPORT = ();

$VERSION = '0.02';

package HCKit::Template::Rule;

sub new {
    my ($class, $body) = @_;
    my $ref = {};
    $ref->{body} = $body;
    $ref->{args} = [];
    return bless $ref, ref($class)||$class;
}

sub body {
    my ($self) = @_;
    return $self->{body};
}

sub append {
    my ($self, $newbody) = @_;
    $self->{body} .= $newbody;
}

sub set_args {
    my ($self, @arg) = @_;
    $self->{args} = \@arg;
}

sub get_args {
    my ($self) = @_;
    return @{$self->{args}};
}

package HCKit::Template;

sub new {
    my $class = shift;
    my $ref = {};
    $ref->{env}  = {};
    $ref->{fun}  = {};
    $ref->{op}   = {};
    $ref->{delayed} = {};    # names of delayed pre-precess fun
    setup($ref);
    bless $ref, ref($class)||$class;
}

sub rewrite_file {
    my ($self, $file) = @_;
    return $self->_rewrite_file($file, $self->{env});
}

sub rewrite_string {
    my ($self, $string) = @_;
    return $self->_rewrite_string($string, $self->{env});
}

sub process_file {
    my ($self, @file) = @_;
    foreach my $f (@file){
	$self->_include_file($f, $self->{env});
    }
}

sub get_var {
    my ($self, $key) = @_;
    return $self->{env}{$key};
}

sub set_var {
    my ($self, $key, $val) = @_;
    $self->{env}{$key} = $val;
}

# utilities ###########################################################

sub add_delayed {
    my ($self, $name) = @_;
    $self->{delayed}->{$name} = 1;
}

sub is_delayed {
    my ($self, $name) = @_;
    return $self->{delayed}->{$name};
}

sub _rewrite_file {
    my ($self, $file, $env) = @_;
    my ($tmpl, $rule, $data) = read_src($file);
    $self->parse_rule($rule, $env);
    $self->parse_data($data, $env);
    return $self->rewrite($tmpl, $env);
}

sub _include_file {
    my ($self, $file, $env) = @_;
    my ($tmpl, $rule, $data) = read_src($file);
    $self->parse_rule($rule, $env);
    $self->parse_data($data, $env);
}

sub _rewrite_string {
    my ($self, $string, $env) = @_;
    my ($tmpl, $rule, $data) = read_src_from_string($string);
    $self->parse_rule($rule, $env);
    $self->parse_data($data, $env);
    return $self->rewrite($tmpl, $env);
}

sub read_src {
    my ($file) = @_;
    local *FILE;
    my @x;  # ($tmpl, $rule, $data);
    my $mode = 0;
    open(FILE, $file) || die "can't open $file: $!";
    while(){
	if( index($_, '---RULE---') >= 0 ){
	    $mode = 1;
	}
	elsif( index($_, '---DATA---') >= 0 ){
	    $mode = 2;
	}
	else{
	    $x[$mode] .= $_;
	}
    }
    close(FILE);
    return @x;
}

sub read_src_from_string {
    my ($str) = @_;
    my @lines = split /\n/, $str;
    my @x;  # ($tmpl, $rule, $data);
    my $mode = 0;
    foreach (@lines){
	if( index($_, '---RULE---') >= 0 ){
	    $mode = 1;
	}
	elsif( index($_, '---DATA---') >= 0 ){
	    $mode = 2;
	}
	else{
	    $x[$mode] .= $_;
	}
    }
    return @x;
}

sub parse_rule {
    my ($self, $rule, $env) = @_;
    $rule ||= "";
    while( $rule =~
	   /
	   <([\w-]+)(\s[^>]+)?>(.*?)<\/\1> |
	   <\*(.*?)\*> |
           (<\*--.*?--\*>)
	   /gsx ){
	my ($sym, $opt, $val, $cmd, $comm) = ($1,$2,$3,$4,$5);
	if( $comm ){ next }
	if( $cmd ){
	    if( $cmd =~ /^\?(.*?)\?$/ ){
		my $instr = trim($1);
		if( $instr =~ /^include\s+(\S+)$/ ){
		    $self->_include_file($1, $env);
		    next;
		}
		die "invalid instruction $cmd";
	    }
	    $self->eval_var_raw($cmd, $env);
	    next;
	}
	my $append = 0;
	my @args;
	$opt = "" if !defined($opt);
	foreach(split " ", $opt){
	    if( $_ eq 'append' || $_ eq '+' ){
		$append = 1;
	    }
	    elsif( $_ eq 'trim' ){
		$val = trim($val);
	    }
	    elsif( $_ eq 'chomp' ){
		$val =~ s/\s+$//;
	    }
	    elsif( $_ eq 'remove-white' ){
		$val = trim($val);
		$val =~ s/>\s+
	    }
	    elsif( /args=(.*)/ ){
		@args = split /,/, $1;
	    }
	}
	my $prev = $env->{$sym};
	if( $prev ){
	    ref($prev) eq "HCKit::Template::Rule"
		|| die "$sym already defined";
	    if( $append ){
		if( @args ){
		    die "cannot specify args in appending rule";
		}
		$prev->append($val);
	    }
	    else{
		$env->{$sym} = HCKit::Template::Rule->new($val);
	    }
	}
	else{
	    $env->{$sym} = HCKit::Template::Rule->new($val);
	    if( @args ){
		$env->{$sym}->set_args(@args);
	    }
	}
    }
}

sub parse_data {
    my ($self, $data, $env) = @_;
    $data ||= "";
    while( $data =~
	   /<([\w-]+)>(.*?)<\/\1>|<\*(.*?)\*>|(<--.*?-->)/gs ){
	my ($sym, $body, $cmd, $comm) = ($1, $2, trim($3), $4);
	if( $comm ){ next }
	if( $sym ){
	    my $val = $self->parse_data_body($body, $env);
	    extend_data($sym, $val, $env);
	}
	else{
	    if( $cmd =~ /^\?(.*?)\?$/ ){
		my $instr = trim($1);
		if( $instr =~ /^include\s+(\S+)$/ ){
		    $self->_include_file($1, $env);
		    next;
		}
		die "invalid instruction $cmd";
	    }
	    $self->eval_var_raw($cmd, $env);
	}
    }
}

sub parse_data_body {
    my ($self, $body, $env) = @_;
    my %hash;
    my $text;
    my $last = 0;
    while( $body =~
	   /(<([\w-]+)>(.*?)<\/\2> |
	     <\*(.*?)\*> |
	     ()
	     )/gsx ){
	my ($match, $sym, $val, $cmd, $cdata) = ($1,$2,$3,$4,$5);
	my $len = length($match);
	my $pre = substr($body, $last, pos($body)-$len-$last);
	$text .= $pre;
	$last = pos($body);
	if( $sym ){
	    my $sub = $self->parse_data_body($val, $env);
	    extend_data($sym, $sub, \%hash);
	}
	elsif( $cdata ){
	    $cdata =~ s/^
	    $cdata =~ s/\]\]>$//;
	    $text .= $cdata;
	}
	else{
	    my ($key, $aux) =
		$cmd =~ /\s*([\w:.-]+)\s*(.*)/;
	    my $val = $self->eval_var($key, $aux, $env);
	    if( ref($val) eq "HASH" ){
		while( my ($sym, $sub) = each %$val ){
		    extend_data($sym, $sub, \%hash);
		}
	    }
	    else{ $text .= $val }
	}
    }
    if( $last < length($body) ){
	$text .= substr($body, $last);
    }
    return %hash ? \%hash : $text;
}

sub extend_data {
    my ($key, $val, $env) = @_;
    if( defined($env->{$key}) ){
	if( ref($env->{$key}) eq 'ARRAY' ){
	    push @{$env->{$key}}, $val;
	}
	else{
	    $env->{$key} = [$env->{$key}, $val];
	}
    }
    else{
	$env->{$key} = $val;
    }
}

sub rewrite {
    my ($self, $tmpl, $env) = @_;
    $tmpl = "" if !defined($tmpl);
    my $last = 0;
    my $output = "";
    while( $tmpl =~
	   /(
	     <\*\s*([\w:.-]+)\s*(.*?)\*> |
	     <\&\s*([\w:.-]+(?:@\w+)?)\s*(.*?)\&>(.*?)<\&\s*\/\4\s*\&> |
	     <\{\s*([\w:.-]+(?:@\w+)?)\s*(.*?)\}>(.*?)<\{\s*\/\7\s*\}>
	     )/gxs ){
	my ($match, $var, $varaux, $fun, $funaux, $funarg,
	    $loop, $loopaux, $loopbody) =
		($1,$2,$3,$4,$5,$6,$7,$8,$9);
	my $len = length($match);
	my $pre = substr($tmpl, $last, pos($tmpl)-$len-$last);
	$output .= $pre;
	$last = pos($tmpl);
	if( $var ){
	    $output .= $self->eval_var($var, $varaux, $env);
	}
	elsif( $fun ){
	    $fun =~ s/@.*//;
	    $output .= $self->eval_fun($fun, $funaux, $funarg, $env);
	}
	elsif( $loop ){
	    $loop =~ s/@.*//;
	    $output .= $self->eval_block($loop, $loopaux, $loopbody, $env);
	}
    }
    if( $last < length($tmpl) ){
	$output .= substr($tmpl, $last);
    }
    return $output;
}

sub eval_var_raw {
    my ($self, $text, $env) = @_;
    my ($key, $aux) = $text =~ /\s*([\w:.-]+)\s*(.*)/;
    return $self->eval_var($key, $aux, $env);
}

sub eval_var {
    my ($self, $key, $aux, $env) = @_;
    $self->eval_construct($key, $aux, { __NEXT__ => $env });
}

sub eval_fun {
    my ($self, $key, $aux, $funarg, $env) = @_;
    my $newenv = { __NEXT__ => $env };
    $self->parse_funarg($funarg, $newenv);
    $self->eval_construct($key, $aux, $newenv);
}

sub eval_block {
    my ($self, $key, $aux, $body, $env) = @_;
    my $newenv = { __NEXT__ => $env, __BODY__ => $body };
    $self->eval_construct($key, $aux, $newenv);
}

sub eval_construct {
    my ($self, $key, $aux, $env) = @_;
    my ($pre, $post) = parse_aux($aux);
    my $stack = [];
    if( $self->is_delayed($key) ){
	$stack = $pre;
    }
    else{
	$self->process_tokens($stack, $env, @$pre);
    }
    my $val = $self->eval_with_fun($key, $stack, $env);
    $stack = [$val];
    $self->process_tokens($stack, $env, @$post);
    return $stack->[0];
}

sub eval_data_construct {
    my ($self, $key, $aux, $env) = @_;
    my ($pre, $post) = parse_aux($aux);
    my $stack = [];
    if( $self->is_delayed($key) ){
	$stack = $pre;
    }
    else{
	$self->process_tokens($stack, $env, @$pre);
    }
    my $val = $self->eval_with_fun($key, $stack, $env);
    $stack = [$val];
    $self->process_tokens($stack, $env, @$post);
    return $stack->[0];
}

sub process_para {
    my ($rule, $stack, $env) = @_;
    my @args = $rule->get_args();
    if( @args ){
	foreach my $p (@args){
	    if( exists $env->{$p} ){ next }
	    $env->{$p} = shift @$stack;
	}
    }
}

sub parse_aux {
    my ($aux) = @_;
    $aux = "" if !defined($aux);
    my $pre = [];
    my $post = [];
    my $ref = $pre;
    while( $aux =~
	   /(
	     [\w:-]+=\"[^\"]*\" |
	     [\w:-]+=\'[^\']*\' |
	     [\w:-]+=[^\'\"\;\s]+ |
	     \"[^\"]*\" |
	     \'[^\']*\' |
	     [^\s=;]+ |
	     ;
	     )/gsx ){
	if( $1 eq ';' ){ $ref = $post; next }
	push @$ref, $1;
    }
    return ($pre, $post);
}

sub parse_funarg {
    my ($self, $funarg, $env) = @_;
    $funarg ||= "";
    while( $funarg =~ /<([\w-]+)>(.*?)<\/\1>/gs ){
	my ($key, $val) = ($1, $2);
	$env->{$key} = $self->rewrite($val, $env);
    }
}

sub process_tokens {
    my ($self, $stack, $env, @tok) = @_;
    my $i;
    for($i=0;$i<=$#tok;$i++){
	my $t = $tok[$i];
	if( $t =~ /^([\w:-]+)=\"([^\"]*)\"$/ ){
	    $env->{$1} = $2;
	}
	elsif( $t =~ /^([\w:-]+)+=\'([^\']*)\'$/ ){
	    $env->{$1} = $2;
	}
	elsif( $t =~ /^([\w:-]+)=([^\'\"\;\s]+)$/ ){
	    $env->{$1} = var_lookup($2, $env);
	}
	elsif( $t =~ /^\"(.*)\"$/ ){
	    push @$stack, $1;
	}
	elsif( $t =~ /^\'(.*)\'$/ ){
	    push @$stack, $1;
	}
	elsif( $t eq "as" ){
	    push @$stack, $tok[++$i];
	}
	elsif( $t =~ /^(\d+|\d+\.\d+)$/ ){
	    push @$stack, $1;
	}
	elsif( $t =~ /^(\d+)\.\.(\d+)$/ ){
	    push @$stack, [$1..$2];
	}
	else{
	    $self->eval_with_op($t, $stack, $env);
	}
    }
}

sub lookup {
    my ($sym, $env) = @_;
    while( $env ){
	if( defined($env->{$sym}) ){
	    return $env->{$sym};
	}
	$env = $env->{'__NEXT__'};
    }
    return undef;
}

sub var_lookup {
    my ($var, $env) = @_;
    my @tok = split /\./, $var;
    my $first = shift @tok;
    my $val = lookup($first, $env);
    foreach my $i (@tok){
	unless( ref($val) eq 'HASH' ){
	    return "";
	}
	$val = $val->{$i};
    }
    return $val;
}

sub eval_with_op {
    my ($self, $expr, $stack, $env) = @_;
    my $val = var_lookup($expr, $env);
    if( defined($val) ){
	unless( ref($val) ){
	    $val = $self->rewrite($val, $env);
	}
	push @$stack, $val;
    }
    else{
	my $op = $self->{op}->{$expr};
	if( $op ){
	    &{$op}($self, $stack, $env);
	}
	else{
	    push @$stack, "";
	}
    }
}

sub eval_with_fun {
    my ($self, $expr, $stack, $env) = @_;
    my $val = var_lookup($expr, $env);
    if( defined($val) ){
	if( ref($val) eq "HCKit::Template::Rule" ){
	    process_para($val, $stack, $env);
	    return $self->rewrite($val->body(), $env);
	}
	elsif( ref($val) ){
	    return $val;
	}
	else{
	    return $val;
	}
    }
    else{
	my $fun = $self->{fun}->{$expr};
	if( $fun ){
	    return &{$fun}($self, $stack, $env);
	}
    }
    return "";
}

# fun ###############################################################

# fun_foreach
#   stack: LIST [IDENT]
#   switches:
#     foreach:sep=SEP
#     foreach:toggle=INIT

sub fun_foreach {
    my ($self, $stack, $env) = @_;
    my $body = $env->{__BODY__};
    my ($ident, $list);
    my $top = pop @$stack;

    if( ref($top) eq "ARRAY" ){
	$ident = "iter";
	$list  = $top;
    }
    else{
	$ident = $top;
	$list  = pop @$stack;
    }
    my $output = "";
    my $join = $env->{'foreach:sep'};
    my $n = 0;
    my $toggle = 0;
    if( defined($env->{'foreach:toggle'}) ){
	$toggle = 1;
	$env->{toggle} = $env->{'foreach:toggle'};
    }
    unless( ref($list) eq "ARRAY" ){
	$list = [$list];
    }
    foreach my $e (@$list){
	if( $join && $n++ > 0 ){
	    $output .= $join;
	}
	$env->{$ident} = $e;
	if( $toggle ){
	    $env->{toggle} = $env->{toggle} ? 0 : 1;
	}
	my $tmp = $self->rewrite($body, $env);
	$output .= $tmp;
    }
    return $output;
}

sub fun_if {
    my ($self, $stack, $env) = @_;
    my ($test) = @$stack;
    if( $test ){
	my $body = $env->{__BODY__};
	return $self->rewrite($body, $env);
    }
    else{ return ""; }
}

sub fun_include {
    my ($self, $stack, $env) = @_;
    my $prev_env = $env->{__NEXT__};
    foreach my $f (@$stack){
	$self->_include_file($f, $prev_env);
    }
    return "";
}

sub fun_set {
    my ($self, $stack, $env) = @_;  # <* set ident val *>
    my $key = shift @$stack;
    $key =~ /^[\w.-]+$/ || die "invalid identifier in set: $key";
    my $ns = [];
    $self->process_tokens($ns, $env, @$stack);
    my $prev = $env->{__NEXT__};
    $prev->{$key} = $ns->[0];
    return "";
}

sub fun_default {
    my ($self, $stack, $env) = @_;  # <* default ident val *>
    my $key = shift @$stack;
    $key =~ /^[\w-]+$/ || die "invalid identifier in set: $key";
    my $bind = lookup($key, $env);
    if( defined $bind ){ return }
    my $ns = [];
    $self->process_tokens($ns, $env, @$stack);
    my $prev = $env->{__NEXT__};
    $prev->{$key} = $ns->[0];
    return "";
}

sub setup_fun {
    my ($ref) = @_;
    my $env = $ref->{fun};
    $env->{foreach}      = \&fun_foreach;
    $env->{if}           = \&fun_if;
    $env->{include}      = \&fun_include;
    $env->{set}          = \&fun_set;
    $ref->{delayed}->{set} = 1;
    $env->{default}      = \&fun_default;
    $ref->{delayed}->{default} = 1;
}

sub op_trim {
    my ($self, $stack, $env) = @_;
    my $s = pop @$stack;
    push @$stack, trim($s);
}

sub op_list_remove_last {
    my ($self, $stack, $env) = @_;
    my $orig = pop @$stack;
    my @list = @$orig;
    pop @list;
    push @$stack, \@list;
}

sub op_list_last {
    my ($self, $stack, $env) = @_;
    my $orig = pop @$stack;
    my $last = pop @$orig;
    push @$stack, $last;
}

sub op_not {
    my ($self, $stack, $env) = @_;
    my $arg = pop @$stack;
    push @$stack, ((!$arg) ? 1 : 0);
}

sub op_eq {
    my ($self, $stack, $env) = @_;
    my $right = pop @$stack;
    my $left  = pop @$stack;
    push @$stack, (($left eq $right) ? 1 : 0);
}

sub op_or {
    my ($self, $stack, $env) = @_;
    my $right = pop @$stack || 0;
    my $left  = pop @$stack || 0;
    push @$stack, (($left || $right) ? 1 : 0);
}

sub op_and {
    my ($self, $stack, $env) = @_;
    my $right = pop @$stack || 0;
    my $left  = pop @$stack || 0;
    push @$stack, (($left && $right) ? 1 : 0);
}

sub op_concat {
    my ($self, $stack, $env) = @_;
    my $right = pop @$stack;
    my $left  = pop @$stack;
    push @$stack, ($left . $right);
}

sub op_lookup {
    my ($self, $stack, $env) = @_;
    my $attr = pop @$stack || return "";
    my $hash = pop @$stack || return "";
    foreach my $a (split /\./, $attr){
	if( $hash && ref($hash) eq "HASH" && exists($hash->{$a}) ){
	    $hash = $hash->{$a};
	}
	else{ return "" }
    }
    push @$stack, $hash;
}

sub setup_op {
    my ($self) = @_;
    my $env = $self->{op};
    $env->{trim} = \&op_trim;
    $env->{'list-remove-last'} = \&op_list_remove_last;
    $env->{'list-last'} = \&op_list_last;
    $env->{'not'} = \&op_not;
    $env->{'eq'} = \&op_eq;
    $env->{'or'} = \&op_or;
    $env->{'and'} = \&op_and;
    $env->{'lookup'} = \&op_lookup;
    $env->{'concat'} = \&op_concat;
}

sub setup {
    my ($ref) = @_;
    setup_fun($ref);
    setup_op($ref);
}

# utilities ##########################################################

sub file_content {
    my ($file) = @_;
    local *FILE;
    local $/;
    $/ = undef;
    open(FILE, $file) || die "can't open $file: $!";
    my $c = ;
    close(FILE);
    return $c;
}

sub trim {
    my ($str) = @_;
    $str ||= "";
    $str =~ s/^\s+//;
    $str =~ s/\s+$//;
    return $str;
}

sub debug_env {
    my ($env, $prefix) = @_;
    if( ref($env) eq "ARRAY" ){
	foreach(@$env){
	    debug_env($_, $prefix);
	}
    }
    elsif( ref($env) eq "HASH" ){
	while( my($key, $val) = each %$env ){
	    print " " x $prefix, "<$key>\n";
	    debug_env($val, $prefix+2);
	    print "\n";
	    print " " x $prefix, "\n";
	}
    }
    else{
	print " " x $prefix, $env;
    }
}

1;
__END__