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