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