From d47bda87223b8eb021403cd458ee0c574bbf2eec Mon Sep 17 00:00:00 2001
From: "sgunderson@bigfoot.com" <>
Date: Fri, 11 Aug 2006 23:17:47 +0200
Subject: [PATCH] Initial checkin.
---
XML/Template.pm | 165 ++++++++++++++++++++++++++++++++++++++++++++++++
attribute.pl | 13 ++++
attribute2.pl | 13 ++++
clone.pl | 13 ++++
clone.xml | 15 +++++
include.pl | 12 ++++
included.xml | 4 ++
master.xml | 14 ++++
simple.pl | 8 +++
simple.xml | 11 ++++
10 files changed, 268 insertions(+)
create mode 100644 XML/Template.pm
create mode 100644 attribute.pl
create mode 100644 attribute2.pl
create mode 100644 clone.pl
create mode 100644 clone.xml
create mode 100644 include.pl
create mode 100644 included.xml
create mode 100644 master.xml
create mode 100644 simple.pl
create mode 100644 simple.xml
diff --git a/XML/Template.pm b/XML/Template.pm
new file mode 100644
index 0000000..3762fe6
--- /dev/null
+++ b/XML/Template.pm
@@ -0,0 +1,165 @@
+#! /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;
diff --git a/attribute.pl b/attribute.pl
new file mode 100644
index 0000000..16826ca
--- /dev/null
+++ b/attribute.pl
@@ -0,0 +1,13 @@
+#! /usr/bin/perl
+use XML::Template;
+
+my $doc = XML::Template::process_file('clone.xml', {
+ 'color' => 'red',
+ '#things' => [
+ { 'li' => 'Raindrops on roses', 'li.class' => 'odd' },
+ { 'li' => 'Whiskers on kittens', 'li.class' => 'even' },
+ { 'li' => 'Bright copper kettles', 'li.class' => 'odd' },
+ { 'li' => 'Warm, woolen mittens', 'li.class' => 'even' }
+ ]
+});
+print $doc->toString;
diff --git a/attribute2.pl b/attribute2.pl
new file mode 100644
index 0000000..038ae92
--- /dev/null
+++ b/attribute2.pl
@@ -0,0 +1,13 @@
+#! /usr/bin/perl
+use XML::Template;
+
+my $doc = XML::Template::process_file('clone.xml', {
+ 'color' => 'blue',
+ '#things' => XML::Template::alternate('li.class', [
+ { 'li' => 'Raindrops on roses' },
+ { 'li' => 'Whiskers on kittens' },
+ { 'li' => 'Bright copper kettles' },
+ { 'li' => 'Warm, woolen mittens'},
+ ], 'odd', 'even')
+});
+print $doc->toString;
diff --git a/clone.pl b/clone.pl
new file mode 100644
index 0000000..0881cb2
--- /dev/null
+++ b/clone.pl
@@ -0,0 +1,13 @@
+#! /usr/bin/perl
+use XML::Template;
+
+my $doc = XML::Template::process_file('clone.xml', {
+ 'color' => 'blue',
+ '#things' => [
+ { 'li' => 'Raindrops on roses' },
+ { 'li' => 'Whiskers on kittens' },
+ { 'li' => 'Bright copper kettles' },
+ { 'li' => 'Warm, woolen mittens'}
+ ]
+});
+print $doc->toString;
diff --git a/clone.xml b/clone.xml
new file mode 100644
index 0000000..d1cb330
--- /dev/null
+++ b/clone.xml
@@ -0,0 +1,15 @@
+
+
+
+ Cloning test
+
+
+ My favourite color is ; I like that very much.
+ All my favourite things:
+
+
+
diff --git a/include.pl b/include.pl
new file mode 100644
index 0000000..26b2562
--- /dev/null
+++ b/include.pl
@@ -0,0 +1,12 @@
+#! /usr/bin/perl
+use XML::Template;
+
+my $doc = XML::Template::process_file('included.xml', {
+ 'color' => 'red'
+});
+my $master = XML::Template::process_file('master.xml', {
+ 'title' => 'Main HTML title',
+ 'h1' => 'Nice heading here',
+ 'contents' => $doc
+});
+print $master->toString;
diff --git a/included.xml b/included.xml
new file mode 100644
index 0000000..e8658cd
--- /dev/null
+++ b/included.xml
@@ -0,0 +1,4 @@
+This document is simply being included into another document by
+ means of attaching DOM nodes together. My favourite color is now
+ .
+
diff --git a/master.xml b/master.xml
new file mode 100644
index 0000000..e3af136
--- /dev/null
+++ b/master.xml
@@ -0,0 +1,14 @@
+
+
+
+
+
+
+
+
+
+ Copyright information goes here.
+
+
diff --git a/simple.pl b/simple.pl
new file mode 100644
index 0000000..04c4eb4
--- /dev/null
+++ b/simple.pl
@@ -0,0 +1,8 @@
+#! /usr/bin/perl
+use XML::Template;
+
+my $doc = XML::Template::process_file('simple.xml', {
+ 'title' => 'A very basic example',
+ '#hello' => 'Hello world!'
+});
+print $doc->toString;
diff --git a/simple.xml b/simple.xml
new file mode 100644
index 0000000..b4bac24
--- /dev/null
+++ b/simple.xml
@@ -0,0 +1,11 @@
+
+
+
+
+
+
+ This will be replaced.
+
+
--
2.39.2