Convert rating.pl to XML::Template. It is dog-slow, but much cleaner.

[wloh] / include / XML / Template.pm

diff --git a/include/XML/Template.pm b/include/XML/Template.pm
new file mode 100644 (file)
index 0000000..3747f83
--- /dev/null
+++ b/include/XML/Template.pm
@@ -0,0 +1,170 @@
+#! /usr/bin/perl
+use XML::DOM;
+use XML::Parser;
+use XML::NamespaceSupport;
+use Scalar::Util;
+package XML::Template;
+
+sub process_file {
+       my ($filename, $obj, $clean) = @_;
+
+       my $parser = XML::DOM::Parser->new;
+       my $doc = $parser->parsefile($filename);
+
+       process($doc, $obj, $clean);
+
+       return $doc;
+}
+
+sub process {
+       my ($node, $obj, $clean, $nsup) = @_;
+       $clean = 1 unless (defined($clean));
+
+       if (!defined($nsup)) {
+               $nsup = XML::NamespaceSupport->new;
+       }
+
+       if (!ref($obj)) {                                                       # overwrite
+               for my $child ($node->getChildNodes) {
+                       $node->removeChild($child);
+               }
+               $node->addText($obj);
+       } elsif (Scalar::Util::blessed($obj) && $obj->isa('XML::DOM::Node')) {  # overwrite
+               for my $child ($node->getChildNodes) {
+                       $node->removeChild($child);
+               }
+
+               if ($obj->isa('XML::DOM::Document')) {
+                       $obj = $obj->getDocumentElement;
+               }
+
+               my $newobj = $obj->cloneNode(1);
+               if ($node->isa('XML::DOM::Document')) {
+                       $newobj->setOwnerDocument($node);
+               } else {
+                       $newobj->setOwnerDocument($node->getOwnerDocument);
+               }
+               $node->appendChild($newobj);
+
+               process($newobj, {}, $clean, $nsup);
+       } elsif (ref($obj) eq 'HASH') {                                         # substitute
+               for my $child ($node->getChildNodes) {
+                       my $processed = 0;
+                       $nsup->push_context;
+
+                       if ($child->getNodeType == XML::DOM::ELEMENT_NODE) {
+                               # see if this node contains any namespace declarations that are relevant
+                               # for us
+                               my $attrs = $child->getAttributes;
+                               if (defined($attrs)) {
+                                       for my $attr ($attrs->getValues) {
+                                               my $name = $attr->getName;
+                                               if ($name =~ /^xmlns:(.*)$/) {
+                                                       $nsup->declare_prefix($1, $attr->getValue);
+                                                       $child->removeAttribute($name) if ($clean);
+                                               }
+                                       }
+                               }
+
+                               my (undef, undef, $tag) = $nsup->process_element_name($child->getTagName);
+
+                               my $id;
+                               my $attrs = $child->getAttributes;
+                               if (defined($attrs)) {
+                                       for my $attr ($attrs->getValues) {
+                                               next if ($attr->getName =~ /^xmlns(:|$)/);
+
+                                               my ($nsuri, undef, $tag) = $nsup->process_attribute_name($attr->getName);
+                                               if ($nsuri eq 'http://template.sesse.net/' && $tag eq 'id') {
+                                                       $id = $attr->getValue;
+                                                       $child->removeAttribute($attr->getName) if ($clean);
+                                               }
+                                       }
+                               }
+
+                               # check all substitutions to see if we found anything
+                               # appropriate
+                               for my $key (keys %$obj) {
+                                       if (($key =~ /^\Q$tag\E\/(.*)$/) ||
+                                           (defined($id) && $key =~ /^#\Q$id\E\/(.*)$/)) {
+                                               $child->setAttribute($1, $obj->{$key});
+                                       }
+
+                                       next if ($processed);
+                                       if ($key eq $tag || (defined($id) && $key eq ('#'.$id))) {
+                                               process($child, $obj->{$key}, $clean, $nsup);
+                                               $processed = 1;
+                                       }
+                               }
+                       }
+
+                       process($child, $obj, $clean, $nsup) unless ($processed);
+                       $nsup->pop_context;
+               }
+       } elsif (ref($obj) eq 'ARRAY') {                                        # repeat
+               my $doc = $node->getOwnerDocument;
+               my $frag = $doc->createDocumentFragment;
+
+               for my $child ($node->getChildNodes) {
+                       $frag->appendChild($child);
+               }
+               for my $child ($node->getChildNodes) {
+                       $node->removeChild($child);
+               }
+               
+               for my $instance (@$obj) {
+                       next if (!defined($instance));
+
+                       my $newnode = $frag->cloneNode(1);
+                       process($newnode, $instance, $clean, $nsup);
+                       $node->appendChild($newnode);
+                       clean($newnode, $nsup) if ($clean);
+               }
+
+               $frag->dispose;
+       }
+
+       clean($node, $nsup) if $clean;
+}
+
+sub clean {
+       my ($node, $nsup) = @_;
+
+       if ($node->getNodeType == XML::DOM::ELEMENT_NODE) {
+               my ($nsuri) = $nsup->process_element_name($node->getTagName);
+               return unless ($nsuri eq 'http://template.sesse.net/');
+
+               # as this is a dummy node, we want to remove it and move everything further up
+               # after we've done any required replacements
+               my $doc = $node->getOwnerDocument;
+               my $frag = $doc->createDocumentFragment;
+
+               for my $child ($node->getChildNodes) {
+                       $frag->appendChild($child);
+               }
+               for my $child ($node->getChildNodes) {
+                       $node->removeChild($child);
+               }
+
+               my $parent = $node->getParentNode;
+
+               $parent->replaceChild($frag, $node);
+       }
+}
+
+sub alternate {
+       my ($tag, $array, @elems) = @_;
+
+       my $i = 0;
+       my $num = scalar @elems;
+
+       for my $ref (@$array) {
+               if (defined($ref)) {
+                       $ref->{$tag} = $elems[$i++ % $num];
+               }
+       }
+
+       return $array;
+}
+
+1;