perl/YATT.pm

   1 #!/usr/bin/perl -w
   2 #
   3 # $Id$
   4 #
   5 # Text template stuff.
   6 #
   7 package YATT;
   8 use strict;
   9
  10 use Storable qw(dclone);
  11 use Data::Dumper;
  12 use File::Basename;
  13 use Carp;
  14 use Exporter;
  15
  16 $YATT::VERSION = sprintf "%d.%03d", '$Revision: 1.16 $ ' =~ m{(\d+)\.(\d+)};
  17
  18 @YATT::ISA = qw( Exporter );
  19
  20 # for $self
  21 use constant OBTR    => 0;
  22 use constant VARS    => 1;
  23 use constant CTXNAME => 2;
  24
  25 # for objtr array
  26 use constant NAME     => 0;
  27 use constant OUTPUT   => 1;
  28 use constant CONTEXTS => 2;
  29 use constant DSTART   => 3;
  30
  31 # INTERNAL: Return all of the generated output
  32 sub return_output {
  33     my ($self, $node) = @_;
  34     my $out = '';
  35
  36     $out .= $node->[OUTPUT];
  37     $node->[OUTPUT] = '';
  38
  39     for (my $i = DSTART; $i < scalar(@$node); $i++) {
  40         if (ref($node->[$i])) {
  41             $out .= $self->return_output($node->[$i]);
  42         }
  43     }
  44     return $out;
  45 }
  46
  47 # INTERNAL: Make sure var exists, just in case
  48 sub subst {
  49     my ($self, $name) = @_;
  50     my $ret = $self->get($name);;
  51
  52     confess "$name not defined" unless defined $ret;;
  53     return $ret;
  54 }
  55
  56 # INTERNAL: given a node, build the output!
  57 sub build_output {
  58     my ($self, $node) = @_;
  59     my $out = '';
  60
  61     if ($node->[CONTEXTS]) {
  62         foreach my $ctx (@{$node->[CONTEXTS]}) {
  63             $out .= $ctx->build_output($ctx->[OBTR]);
  64         }
  65         return $out;
  66     }
  67
  68     for (my $i = DSTART; defined($node->[$i]); $i++) {
  69         my $d = $node->[$i];
  70
  71         if (ref($d)) {
  72             $out .= $self->return_output($d);
  73         } else {
  74             my $buf = $node->[$i];
  75             my $pass = 0;
  76
  77             while ($buf =~ s/\%\[([^][%]+)\]/$self->subst($1)/ge) {
  78                 if ($pass++ > 10) {
  79                     die("recursive var subst?\n");
  80                 }
  81             }
  82             $out .= $buf;
  83         }
  84     }
  85     return $out;
  86 }
  87
  88 # INTERNAL: Find the node that corrosponds to an OID
  89 sub find_node {
  90     my ($self, $path) = @_;
  91     my @oid = split /\./, $path if $path;
  92     my $node = $self->[OBTR];
  93
  94     while (my $cmp = shift(@oid)) {
  95         my $old = $node;
  96         for (my $i = DSTART; $i < scalar(@$node); $i++) {
  97             if (ref($node->[$i]) && ($node->[$i][NAME] eq $cmp)) {
  98                 $node = $node->[$i];
  99                 last;
 100             }
 101         }
 102         if ($old == $node) {
 103             die("could't find $cmp in $path\n");
 104         }
 105     }
 106     return $node;
 107 }
 108
 109 # INTERNAL: read an entire file
 110 sub slurp {
 111     my ($fname) = @_;
 112     local($/) = undef;
 113
 114     open FN, "<", $fname or confess "Unable to open '$fname'";
 115     my $data = <FN>;
 116     close(FN);
 117
 118     return $data;
 119 }
 120
 121 # INTERNAL: read file, preprocess for includes, strip out comments
 122 sub preprocess {
 123     my ($fname) = @_;
 124     my $dir = &dirname($fname) . '/';
 125     my $data = &slurp($fname);
 126
 127     study $data;
 128
 129     # strip all comments
 130     $data =~ s/[ \t]*\%\[#\].*$//gm;
 131
 132     # fetch all includes (recursive!)
 133     $data =~ s/^\s*\%\s*(?:include|INCLUDE)\s*[\"\[]([A-Za-z-_]+)[\"\]]\s*\n/&preprocess($dir . $1)/gsme;
 134
 135     return $data;
 136 }
 137
 138 # INTERNAL: called from load to check for duplicate names
 139 sub check_name {
 140     my ($array, $path, $name) = @_;
 141
 142     for (my $i = DSTART; $i < scalar(@$array); $i++) {
 143         if (ref($array->[$i])) {
 144             if ($array->[$i]->[NAME] eq $name) {
 145                 confess join('.', @$path) .  " defined twice!";
 146             }
 147         }
 148     }
 149 }
 150
 151 # load template file. more then one can be loaded into a template object.
 152 sub load {
 153     my ($self, $fname) = @_;
 154     my $dir = &dirname($fname) . '/';
 155
 156     my @stack;
 157     my @path;
 158     my $text = undef;
 159     my $cur = $self->[OBTR];
 160     my $data = &preprocess($fname);
 161
 162     pos($data) = 0;
 163     while ($data =~ m/\G(.*?)\%\s*(begin|end|BEGIN|END)\s*\[([A-Za-z-_]+)\]\s*\n/gsm) {
 164         my $text = $1;
 165         my $type = lc($2);
 166         my $name = $3;
 167
 168         push @$cur, $text;
 169
 170         if ($type eq 'end') {
 171             $cur = pop @stack;
 172             pop @path;
 173         } elsif ($type eq 'begin') {
 174             my $n = [ $name, '', undef ];
 175
 176             push @path, $name;
 177             &check_name($cur, \@path, $name);
 178
 179             push @$cur, $n;
 180             push @stack, $cur;
 181             $cur = $n;
 182         }
 183     }
 184     confess "missmatched begin/end pairs at EOF" if ($cur != $self->[OBTR]);
 185 }
 186
 187 # Create a new text template object
 188 sub new {
 189     local($_);
 190     my $proto = shift;
 191     my $class = ref($proto) || $proto;
 192     my $self = [];
 193
 194     $self->[VARS] = {};
 195     $self->[OBTR] = [ 'ROOT', '', undef ];
 196     $self->[CTXNAME] = "ROOT";
 197
 198     bless ($self, $class);
 199
 200     foreach (@_) {
 201         $self->load($_);
 202     }
 203     return $self;
 204 }
 205
 206 # Set a variable to some value
 207 sub assign {
 208     my ($self, $var, $value) = @_;
 209
 210     if (ref($var) eq 'HASH') {
 211         while (my ($va, $vl) = each %$var) {
 212             $self->[VARS]->{$va} = $vl;
 213         }
 214     } else {
 215         $self->[VARS]->{$var} = $value;
 216     }
 217 }
 218
 219 # Clear all assignments
 220 sub unset {
 221     my ($self, $var) = @_;
 222
 223     if (ref($var) eq 'ARRAY') {
 224         foreach my $va (@$var) {
 225             undef($self->[VARS]->{$va});
 226         }
 227     } elsif (defined($var)) {
 228         undef($self->[VARS]->{$var});
 229     } else {
 230         $self->[VARS] = {};
 231     }
 232 }
 233
 234 # Get an assigned value
 235 sub get {
 236     my ($self, $name) = @_;
 237     return $self->[VARS]->{$name};
 238 }
 239
 240 # Return output, starting at a given node
 241 sub output {
 242     my ($self, $path, $ctx) = @_;
 243
 244     my $obj = $self->find_node($path);
 245     return $self->return_output($obj);
 246 }
 247
 248 # Generate text from an object tree
 249 sub parse {
 250     my ($self, $path) = @_;
 251     my $obj = $self->find_node($path);
 252
 253     $obj->[OUTPUT] .= $self->build_output($obj);
 254 }
 255
 256 # silly helper, find object in list that matches name.
 257 sub find_object {
 258     my ($list, $name) = @_;
 259
 260     my @foo = grep { $_->[CTXNAME] eq $name } @$list;
 261     return $foo[0];
 262 }
 263
 264 # Create a new object that is a copy of the current one
 265 sub context {
 266     my ($self, $path, $name) = @_;
 267     my $obj = $self->find_node($path);
 268     my $ctx = &find_object($obj->[CONTEXTS], $name);
 269
 270     if (!defined($ctx)) {
 271         $ctx = new YATT;
 272         $ctx->[VARS] = dclone($self->[VARS]);
 273         $ctx->[OBTR] = dclone($obj);
 274         $ctx->[OBTR]->[CONTEXTS] = undef;
 275         $ctx->[CTXNAME] = $name;
 276
 277         push @{$obj->[CONTEXTS]}, $ctx;
 278     }
 279     return $ctx;
 280 }
 281
 282 1;