--- /dev/null
+#! /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;
+ }
+ $nsup->push_context;
+
+ # see if this node contains any namespace declarations that are relevant
+ # for us
+ my $attrs = $node->getAttributes;
+ if (defined($attrs)) {
+ for my $attr ($attrs->getValues) {
+ my $name = $attr->getName;
+ if ($name =~ /^xmlns:(.*)$/) {
+ $nsup->declare_prefix($1, $attr->getValue);
+ $node->removeAttribute($name) if ($clean);
+ }
+ }
+ }
+
+ 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);
+ } elsif (ref($obj) eq 'HASH') { # substitute
+ for my $child ($node->getChildNodes) {
+ my $processed = 0;
+
+ if ($child->getNodeType == XML::DOM::ELEMENT_NODE) {
+ 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, $prefix, $tag) = $nsup->process_attribute_name($attr->getName);
+ $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 =~ /^#\Q$id\E$/)) {
+ process($child, $obj->{$key}, $clean, $nsup);
+ $processed = 1;
+ }
+ }
+ }
+
+ process($child, $obj, $clean, $nsup) unless ($processed);
+ }
+ } 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) {
+
+ my $newnode = $frag->cloneNode(1);
+ process($newnode, $instance, $clean, $nsup);
+ $node->appendChild($newnode);
+ clean($newnode, $nsup) if ($clean);
+ }
+
+ $frag->dispose;
+ $nsup->pop_context;
+ return;
+ }
+
+ clean($node, $nsup) if $clean;
+ $nsup->pop_context;
+}
+
+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) {
+ $ref->{$tag} = $elems[$i++ % $num];
+ }
+
+ return $array;
+}
+
+1;
projects / xml-template / commitdiff