From: Rex Feany Date: Fri, 22 Feb 2008 01:44:25 +0000 (-0800) Subject: perl version I had laying around X-Git-Url: https://git.rexfeany.com/?a=commitdiff_plain;h=79c0c607160a320cec240bc33b08e28283232693;p=yatt.git perl version I had laying around --- diff --git a/perl/YATT.pm b/perl/YATT.pm new file mode 100644 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 = ; + 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;