perl version I had laying around

diff --git a/perl/YATT.pm b/perl/YATT.pm
new file mode 100644 (file)
index 0000000..a05dcf6
--- /dev/null
+++ b/perl/YATT.pm
@@ -0,0 +1,282 @@
+#!/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;