#!/usr/bin/perl -w
#
# $Id$
#
# Text template stuff.
#
package YATT;
use strict;

use Storable qw(dclone);
use Data::Dumper;
use File::Basename;
use Carp;
use Exporter;

$YATT::VERSION = sprintf "%d.%03d", '$Revision: 1.16 $ ' =~ m{(\d+)\.(\d+)};

@YATT::ISA = qw( Exporter );

# for $self
use constant OBTR    => 0;
use constant VARS    => 1;
use constant CTXNAME => 2;

# for objtr array
use constant NAME     => 0;
use constant OUTPUT   => 1;
use constant CONTEXTS => 2;
use constant DSTART   => 3;

# INTERNAL: Return all of the generated output
sub return_output {
    my ($self, $node) = @_;
    my $out = '';

    $out .= $node->[OUTPUT];
    $node->[OUTPUT] = '';

    for (my $i = DSTART; $i < scalar(@$node); $i++) {
        if (ref($node->[$i])) {
            $out .= $self->return_output($node->[$i]);
        }
    }
    return $out;
}

# INTERNAL: Make sure var exists, just in case
sub subst {
    my ($self, $name) = @_;
    my $ret = $self->get($name);;

    confess "$name not defined" unless defined $ret;;
    return $ret;
}

# INTERNAL: given a node, build the output!
sub build_output {
    my ($self, $node) = @_;
    my $out = '';

    if ($node->[CONTEXTS]) {
        foreach my $ctx (@{$node->[CONTEXTS]}) {
            $out .= $ctx->build_output($ctx->[OBTR]);
        }
        return $out;
    }

    for (my $i = DSTART; defined($node->[$i]); $i++) {
        my $d = $node->[$i];

        if (ref($d)) {
            $out .= $self->return_output($d);
        } else {
            my $buf = $node->[$i];
            my $pass = 0;

            while ($buf =~ s/\%\[([^][%]+)\]/$self->subst($1)/ge) {
                if ($pass++ > 10) {
                    die("recursive var subst?\n");
                }
            }
            $out .= $buf;
        }
    }
    return $out;
}

# INTERNAL: Find the node that corrosponds to an OID
sub find_node {
    my ($self, $path) = @_;
    my @oid = split /\./, $path if $path;
    my $node = $self->[OBTR];

    while (my $cmp = shift(@oid)) {
        my $old = $node;
        for (my $i = DSTART; $i < scalar(@$node); $i++) {
            if (ref($node->[$i]) && ($node->[$i][NAME] eq $cmp)) {
                $node = $node->[$i];
                last;
            }
        }
        if ($old == $node) {
            die("could't find $cmp in $path\n");
        }
    }
    return $node;
}

# INTERNAL: read an entire file
sub slurp {
    my ($fname) = @_;
    local($/) = undef;

    open FN, "<", $fname or confess "Unable to open '$fname'";
    my $data = <FN>;
    close(FN);

    return $data;
}

# INTERNAL: read file, preprocess for includes, strip out comments
sub preprocess {
    my ($fname) = @_;
    my $dir = &dirname($fname) . '/';
    my $data = &slurp($fname);

    study $data;

    # strip all comments
    $data =~ s/[ \t]*\%\[#\].*$//gm;

    # fetch all includes (recursive!)
    $data =~ s/^\s*\%\s*(?:include|INCLUDE)\s*[\"\[]([A-Za-z-_]+)[\"\]]\s*\n/&preprocess($dir . $1)/gsme;

    return $data;
}

# INTERNAL: called from load to check for duplicate names
sub check_name {
    my ($array, $path, $name) = @_;

    for (my $i = DSTART; $i < scalar(@$array); $i++) {
        if (ref($array->[$i])) {
            if ($array->[$i]->[NAME] eq $name) {
                confess join('.', @$path) .  " defined twice!";
            }
        }
    }
}

# load template file. more then one can be loaded into a template object.
sub load {
    my ($self, $fname) = @_;
    my $dir = &dirname($fname) . '/';

    my @stack;
    my @path;
    my $text = undef;
    my $cur = $self->[OBTR];
    my $data = &preprocess($fname);

    pos($data) = 0;
    while ($data =~ m/\G(.*?)\%\s*(begin|end|BEGIN|END)\s*\[([A-Za-z-_]+)\]\s*\n/gsm) {
        my $text = $1;
        my $type = lc($2);
        my $name = $3;

        push @$cur, $text;

        if ($type eq 'end') {
            $cur = pop @stack;
            pop @path;
        } elsif ($type eq 'begin') {
            my $n = [ $name, '', undef ];                                                                                       

            push @path, $name;
            &check_name($cur, \@path, $name);

            push @$cur, $n;
            push @stack, $cur;
            $cur = $n;
        } 
    }
    confess "missmatched begin/end pairs at EOF" if ($cur != $self->[OBTR]);
}

# Create a new text template object
sub new {
    local($_);
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = [];

    $self->[VARS] = {};
    $self->[OBTR] = [ 'ROOT', '', undef ];
    $self->[CTXNAME] = "ROOT";

    bless ($self, $class);

    foreach (@_) {
        $self->load($_);
    }
    return $self;
}

# Set a variable to some value 
sub assign {
    my ($self, $var, $value) = @_;

    if (ref($var) eq 'HASH') {
        while (my ($va, $vl) = each %$var) {
            $self->[VARS]->{$va} = $vl;
        }
    } else {
        $self->[VARS]->{$var} = $value;
    }
}

# Clear all assignments
sub unset {
    my ($self, $var) = @_;

    if (ref($var) eq 'ARRAY') {
        foreach my $va (@$var) {
            undef($self->[VARS]->{$va});
        }
    } elsif (defined($var)) {
        undef($self->[VARS]->{$var});
    } else {
        $self->[VARS] = {};
    }
}

# Get an assigned value
sub get {
    my ($self, $name) = @_;
    return $self->[VARS]->{$name};
}

# Return output, starting at a given node
sub output {
    my ($self, $path, $ctx) = @_;

    my $obj = $self->find_node($path);
    return $self->return_output($obj);
}

# Generate text from an object tree
sub parse {
    my ($self, $path) = @_;
    my $obj = $self->find_node($path);

    $obj->[OUTPUT] .= $self->build_output($obj);
}

# silly helper, find object in list that matches name.
sub find_object {
    my ($list, $name) = @_;

    my @foo = grep { $_->[CTXNAME] eq $name } @$list;
    return $foo[0];
}

# Create a new object that is a copy of the current one
sub context {
    my ($self, $path, $name) = @_;
    my $obj = $self->find_node($path);
    my $ctx = &find_object($obj->[CONTEXTS], $name);

    if (!defined($ctx)) {
        $ctx = new YATT;
        $ctx->[VARS] = dclone($self->[VARS]);
        $ctx->[OBTR] = dclone($obj);
        $ctx->[OBTR]->[CONTEXTS] = undef;
        $ctx->[CTXNAME] = $name;

        push @{$obj->[CONTEXTS]}, $ctx;
    }
    return $ctx;
}

1;
