git.sesse.net Git - xml-template/blob - perl-sax/XML/TemplateSAX/Handler.pm

   1 #! /usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5 use Data::Dumper;
   6
   7 package XML::TemplateSAX::Handler;
   8 use base qw(XML::SAX::Base);
   9
  10 sub new {
  11         my $class = shift;
  12         my %options = @_;
  13
  14         my $self = {
  15                 obj => $options{'Content'},
  16                 stack => [],
  17                 Handler => $options{'Handler'}
  18         };
  19         bless($self, $class);
  20         return $self;
  21 }
  22
  23 sub start_element {
  24         my ($self, $data) = @_;
  25         my $obj = $self->{'obj'};
  26
  27         # find the ID, if any
  28         my $id = $data->{'Attributes'}->{'{http://template.sesse.net/}id'};
  29         $id = $id->{'Value'} if (defined($id));
  30
  31         #
  32         # If we have multiple elements with the same name within each other,
  33         # we need to keep track of how many there are, so check here and increment.
  34         # end_element will decrement and optionally pop the stack.
  35         #
  36         my $stack = $self->{'stack'};
  37         if (scalar @$stack > 0) {
  38                 my $top = $stack->[scalar @$stack - 1];
  39
  40                 if ($data->{'Name'} eq $top->[0]) {
  41                         ++$top->[1];
  42                 }
  43         }
  44
  45         # within a replacement; just ignore everything
  46         return if (!defined($obj));
  47
  48         # within a cloning; slurp it up
  49         if (ref($obj) eq 'XML::TemplateSAX::Buffer') {
  50                 $obj->start_element($data);
  51                 return;
  52         }
  53
  54         # substitution: see if this element matches anything. if so,
  55         # descend down into the tree.
  56         if (ref($obj) eq 'HASH') {
  57                 # first of all, see if we have an attribute match.
  58                 for my $key (keys %$obj) {
  59                         next unless ($key =~ /^(#?)(.*)\/(.*)$/);
  60                         my ($idmarker, $name, $attr) = ($1, $2, $3);
  61
  62                         if (($idmarker eq '#' && $id eq $name) ||
  63                             ($idmarker ne '#' && $data->{'LocalName'} eq $name)) {
  64                                 $data->{'Attributes'}->{$attr} = {
  65                                         Prefix => '',
  66                                         LocalName => $attr,
  67                                         Name => $attr,
  68                                         NamespaceURI => '',
  69                                         Value => $obj->{$key}
  70                                 };
  71                         }
  72                 }
  73
  74                 my $match = undef;
  75                 for my $key (keys %$obj) {
  76                         if ($key =~ /^#(.*)$/) {
  77                                 if (defined($id) && $id eq $1) {
  78                                         $match = $obj->{$key};
  79                                         last;
  80                                 }
  81                         } else {
  82                                 if ($data->{'LocalName'} eq $key) {
  83                                         $match = $obj->{$key};
  84                                         last;
  85                                 }
  86                         }
  87                 }
  88
  89                 if (defined($match)) {
  90                         $self->SUPER::start_element($data);
  91
  92                         push @{$self->{'stack'}}, [ $data->{'Name'}, 0, $obj ];
  93
  94                         #
  95                         # This is sort of ugly. We special-case replacement by outputting
  96                         # the string immediately, and then just ignoring the rest of the
  97                         # events until we get to the right end tag. It's not 100% technically
  98                         # correct for the case where you replace an entire document by a
  99                         # string, but that's nonsensical anyway.
 100                         #
 101                         if (!ref($match)) {
 102                                 $self->SUPER::characters({ Data => $match });
 103                                 $self->{'obj'} = undef;
 104                                 return;
 105                         }
 106
 107                         #
 108                         # Sort of the same, for cloning. Cloning works by gobbling up all the all the
 109                         # input until the end element, and put it into a buffer. when we get to the end
 110                         # element, spew it all out again as many times as we need, onto ourselves so we
 111                         # get filtering etc. right.
 112                         #
 113                         # We let the buffer object keep the actual array, so we can fetch it out later.
 114                         #
 115                         if (ref($match) eq 'ARRAY') {
 116                                 $self->{'obj'} = XML::TemplateSAX::Buffer->new($match);
 117                                 return;
 118                         }
 119
 120                         #
 121                         # If someone tries to insert a full tree, do it, just like the character
 122                         # replacement above.
 123                         #
 124                         if (ref($match) eq 'XML::TemplateSAX::Buffer') {
 125                                 $match->replay($self);
 126                                 $self->{'obj'} = undef;
 127                         }
 128
 129                         $self->{'obj'} = $match;
 130                         return;
 131                 }
 132         }
 133
 134
 135         $self->SUPER::start_element($data);
 136 }
 137
 138 sub characters {
 139         my ($self, $data) = @_;
 140
 141         return if (!defined($self->{'obj'}));
 142
 143         if (ref($self->{'obj'}) eq 'XML::TemplateSAX::Buffer') {
 144                 $self->{'obj'}->characters($data);
 145                 return;
 146         }
 147
 148         $self->SUPER::characters($data);
 149 }
 150
 151 sub comment {
 152         my ($self, $data) = @_;
 153
 154         return if (!defined($self->{'obj'}));
 155
 156         if (ref($self->{'obj'}) eq 'XML::TemplateSAX::Buffer') {
 157                 $self->{'obj'}->comment($data);
 158                 return;
 159         }
 160
 161         $self->SUPER::comment($data);
 162 }
 163
 164 sub processing_instruction {
 165         my ($self, $data) = @_;
 166
 167         return if (!defined($self->{'obj'}));
 168
 169         if (ref($self->{'obj'}) eq 'XML::TemplateSAX::Buffer') {
 170                 $self->{'obj'}->processing_instruction($data);
 171                 return;
 172         }
 173
 174         $self->SUPER::processing_instruction($data);
 175 }
 176
 177 sub end_element {
 178         my ($self, $data) = @_;
 179
 180         my $stack = $self->{'stack'};
 181         if (scalar @$stack > 0) {
 182                 my $top = $stack->[scalar @$stack - 1];
 183
 184                 if ($data->{'Name'} eq $top->[0]) {
 185                         if ($top->[1] == 0) {
 186                                 my $obj = $self->{'obj'};
 187
 188                                 # did we just finish a clone operation?
 189                                 if (ref($obj) eq 'XML::TemplateSAX::Buffer') {
 190                                         for my $instance (@{$obj->{'ptr'}}) {
 191                                                 $self->{'obj'} = $instance;
 192                                                 $obj->replay($self);
 193                                         }
 194                                 }
 195
 196                                 $self->SUPER::end_element($data);
 197                                 $self->{'obj'} = $top->[2];
 198                                 pop @$stack;
 199                                 return;
 200                         } else {
 201                                 --$top->[1];
 202                         }
 203                 }
 204         }
 205
 206         return if (!defined($self->{'obj'}));
 207
 208         if (ref($self->{'obj'}) eq 'XML::TemplateSAX::Buffer') {
 209                 $self->{'obj'}->end_element($data);
 210                 return;
 211         }
 212
 213         $self->SUPER::end_element($data);
 214 }
 215
 216 1;