10 use Storable qw(dclone);
16 $YATT::VERSION = sprintf "%d.%03d", '$Revision: 1.16 $ ' =~ m{(\d+)\.(\d+)};
18 @YATT::ISA = qw( Exporter );
21 use constant OBTR => 0;
22 use constant VARS => 1;
23 use constant CTXNAME => 2;
26 use constant NAME => 0;
27 use constant OUTPUT => 1;
28 use constant CONTEXTS => 2;
29 use constant DSTART => 3;
31 # INTERNAL: Return all of the generated output
33 my ($self, $node) = @_;
36 $out .= $node->[OUTPUT];
39 for (my $i = DSTART; $i < scalar(@$node); $i++) {
40 if (ref($node->[$i])) {
41 $out .= $self->return_output($node->[$i]);
47 # INTERNAL: Make sure var exists, just in case
49 my ($self, $name) = @_;
50 my $ret = $self->get($name);;
52 confess "$name not defined" unless defined $ret;;
56 # INTERNAL: given a node, build the output!
58 my ($self, $node) = @_;
61 if ($node->[CONTEXTS]) {
62 foreach my $ctx (@{$node->[CONTEXTS]}) {
63 $out .= $ctx->build_output($ctx->[OBTR]);
68 for (my $i = DSTART; defined($node->[$i]); $i++) {
72 $out .= $self->return_output($d);
74 my $buf = $node->[$i];
77 while ($buf =~ s/\%\[([^][%]+)\]/$self->subst($1)/ge) {
79 die("recursive var subst?\n");
88 # INTERNAL: Find the node that corrosponds to an OID
90 my ($self, $path) = @_;
91 my @oid = split /\./, $path if $path;
92 my $node = $self->[OBTR];
94 while (my $cmp = shift(@oid)) {
96 for (my $i = DSTART; $i < scalar(@$node); $i++) {
97 if (ref($node->[$i]) && ($node->[$i][NAME] eq $cmp)) {
103 die("could't find $cmp in $path\n");
109 # INTERNAL: read an entire file
114 open FN, "<", $fname or confess "Unable to open '$fname'";
121 # INTERNAL: read file, preprocess for includes, strip out comments
124 my $dir = &dirname($fname) . '/';
125 my $data = &slurp($fname);
130 $data =~ s/[ \t]*\%\[#\].*$//gm;
132 # fetch all includes (recursive!)
133 $data =~ s/^\s*\%\s*(?:include|INCLUDE)\s*[\"\[]([A-Za-z-_]+)[\"\]]\s*\n/&preprocess($dir . $1)/gsme;
138 # INTERNAL: called from load to check for duplicate names
140 my ($array, $path, $name) = @_;
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!";
151 # load template file. more then one can be loaded into a template object.
153 my ($self, $fname) = @_;
154 my $dir = &dirname($fname) . '/';
159 my $cur = $self->[OBTR];
160 my $data = &preprocess($fname);
163 while ($data =~ m/\G(.*?)\%\s*(begin|end|BEGIN|END)\s*\[([A-Za-z-_]+)\]\s*\n/gsm) {
170 if ($type eq 'end') {
173 } elsif ($type eq 'begin') {
174 my $n = [ $name, '', undef ];
177 &check_name($cur, \@path, $name);
184 confess "missmatched begin/end pairs at EOF" if ($cur != $self->[OBTR]);
187 # Create a new text template object
191 my $class = ref($proto) || $proto;
195 $self->[OBTR] = [ 'ROOT', '', undef ];
196 $self->[CTXNAME] = "ROOT";
198 bless ($self, $class);
206 # Set a variable to some value
208 my ($self, $var, $value) = @_;
210 if (ref($var) eq 'HASH') {
211 while (my ($va, $vl) = each %$var) {
212 $self->[VARS]->{$va} = $vl;
215 $self->[VARS]->{$var} = $value;
219 # Clear all assignments
221 my ($self, $var) = @_;
223 if (ref($var) eq 'ARRAY') {
224 foreach my $va (@$var) {
225 undef($self->[VARS]->{$va});
227 } elsif (defined($var)) {
228 undef($self->[VARS]->{$var});
234 # Get an assigned value
236 my ($self, $name) = @_;
237 return $self->[VARS]->{$name};
240 # Return output, starting at a given node
242 my ($self, $path, $ctx) = @_;
244 my $obj = $self->find_node($path);
245 return $self->return_output($obj);
248 # Generate text from an object tree
250 my ($self, $path) = @_;
251 my $obj = $self->find_node($path);
253 $obj->[OUTPUT] .= $self->build_output($obj);
256 # silly helper, find object in list that matches name.
258 my ($list, $name) = @_;
260 my @foo = grep { $_->[CTXNAME] eq $name } @$list;
264 # Create a new object that is a copy of the current one
266 my ($self, $path, $name) = @_;
267 my $obj = $self->find_node($path);
268 my $ctx = &find_object($obj->[CONTEXTS], $name);
270 if (!defined($ctx)) {
272 $ctx->[VARS] = dclone($self->[VARS]);
273 $ctx->[OBTR] = dclone($obj);
274 $ctx->[OBTR]->[CONTEXTS] = undef;
275 $ctx->[CTXNAME] = $name;
277 push @{$obj->[CONTEXTS]}, $ctx;