git.sesse.net Git - xml-template/blob - perl/XML/Template.pm

   1 #! /usr/bin/perl
   2 use XML::DOM;
   3 use XML::Parser;
   4 use XML::NamespaceSupport;
   5 use Scalar::Util;
   6 package XML::Template;
   7
   8 sub process_file {
   9         my ($filename, $obj, $clean) = @_;
  10
  11         my $parser = XML::DOM::Parser->new;
  12         my $doc = $parser->parsefile($filename);
  13
  14         process($doc, $obj, $clean);
  15
  16         return $doc;
  17 }
  18
  19 sub process {
  20         my ($node, $obj, $clean, $nsup) = @_;
  21         $clean = 1 unless (defined($clean));
  22
  23         if (!defined($nsup)) {
  24                 $nsup = XML::NamespaceSupport->new;
  25         }
  26
  27         if (!ref($obj)) {                                                       # overwrite
  28                 for my $child ($node->getChildNodes) {
  29                         $node->removeChild($child);
  30                 }
  31                 $node->addText($obj);
  32         } elsif (Scalar::Util::blessed($obj) && $obj->isa('XML::DOM::Node')) {  # overwrite
  33                 for my $child ($node->getChildNodes) {
  34                         $node->removeChild($child);
  35                 }
  36
  37                 if ($obj->isa('XML::DOM::Document')) {
  38                         $obj = $obj->getDocumentElement;
  39                 }
  40
  41                 my $newobj = $obj->cloneNode(1);
  42                 if ($node->isa('XML::DOM::Document')) {
  43                         $newobj->setOwnerDocument($node);
  44                 } else {
  45                         $newobj->setOwnerDocument($node->getOwnerDocument);
  46                 }
  47                 $node->appendChild($newobj);
  48         } elsif (ref($obj) eq 'HASH') {                                         # substitute
  49                 for my $child ($node->getChildNodes) {
  50                         my $processed = 0;
  51                         $nsup->push_context;
  52
  53                         if ($child->getNodeType == XML::DOM::ELEMENT_NODE) {
  54                                 # see if this node contains any namespace declarations that are relevant
  55                                 # for us
  56                                 my $attrs = $child->getAttributes;
  57                                 if (defined($attrs)) {
  58                                         for my $attr ($attrs->getValues) {
  59                                                 my $name = $attr->getName;
  60                                                 if ($name =~ /^xmlns:(.*)$/) {
  61                                                         $nsup->declare_prefix($1, $attr->getValue);
  62                                                         $child->removeAttribute($name) if ($clean);
  63                                                 }
  64                                         }
  65                                 }
  66                                 print $child->getTagName, "\n";
  67
  68                                 my (undef, undef, $tag) = $nsup->process_element_name($child->getTagName);
  69
  70                                 my $id;
  71                                 my $attrs = $child->getAttributes;
  72                                 if (defined($attrs)) {
  73                                         for my $attr ($attrs->getValues) {
  74                                                 next if ($attr->getName =~ /^xmlns(:|$)/);
  75
  76                                                 my ($nsuri, undef, $tag) = $nsup->process_attribute_name($attr->getName);
  77                                                 if ($nsuri eq 'http://template.sesse.net/' && $tag eq 'id') {
  78                                                         $id = $attr->getValue;
  79                                                         $child->removeAttribute($attr->getName) if ($clean);
  80                                                 }
  81                                         }
  82                                 }
  83
  84                                 # check all substitutions to see if we found anything
  85                                 # appropriate
  86                                 for my $key (keys %$obj) {
  87                                         if (($key =~ /^\Q$tag\E\/(.*)$/) ||
  88                                             (defined($id) && $key =~ /^#\Q$id\E\/(.*)$/)) {
  89                                                 $child->setAttribute($1, $obj->{$key});
  90                                         }
  91
  92                                         next if ($processed);
  93                                         if ($key eq $tag || (defined($id) && $key eq ('#'.$id))) {
  94                                                 process($child, $obj->{$key}, $clean, $nsup);
  95                                                 $processed = 1;
  96                                         }
  97                                 }
  98                         }
  99
 100                         process($child, $obj, $clean, $nsup) unless ($processed);
 101                         $nsup->pop_context;
 102                 }
 103         } elsif (ref($obj) eq 'ARRAY') {                                        # repeat
 104                 my $doc = $node->getOwnerDocument;
 105                 my $frag = $doc->createDocumentFragment;
 106
 107                 for my $child ($node->getChildNodes) {
 108                         $frag->appendChild($child);
 109                 }
 110                 for my $child ($node->getChildNodes) {
 111                         $node->removeChild($child);
 112                 }
 113
 114                 for my $instance (@$obj) {
 115
 116                         my $newnode = $frag->cloneNode(1);
 117                         process($newnode, $instance, $clean, $nsup);
 118                         $node->appendChild($newnode);
 119                         clean($newnode, $nsup) if ($clean);
 120                 }
 121
 122                 $frag->dispose;
 123                 return;
 124         }
 125
 126         clean($node, $nsup) if $clean;
 127 }
 128
 129 sub clean {
 130         my ($node, $nsup) = @_;
 131
 132         if ($node->getNodeType == XML::DOM::ELEMENT_NODE) {
 133                 my ($nsuri) = $nsup->process_element_name($node->getTagName);
 134                 return unless ($nsuri eq 'http://template.sesse.net/');
 135
 136                 # as this is a dummy node, we want to remove it and move everything further up
 137                 # after we've done any required replacements
 138                 my $doc = $node->getOwnerDocument;
 139                 my $frag = $doc->createDocumentFragment;
 140
 141                 for my $child ($node->getChildNodes) {
 142                         $frag->appendChild($child);
 143                 }
 144                 for my $child ($node->getChildNodes) {
 145                         $node->removeChild($child);
 146                 }
 147
 148                 my $parent = $node->getParentNode;
 149
 150                 $parent->replaceChild($frag, $node);
 151         }
 152 }
 153
 154 sub alternate {
 155         my ($tag, $array, @elems) = @_;
 156
 157         my $i = 0;
 158         my $num = scalar @elems;
 159
 160         for my $ref (@$array) {
 161                 $ref->{$tag} = $elems[$i++ % $num];
 162         }
 163
 164         return $array;
 165 }
 166
 167 1;