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         $nsup->push_context;
  27
  28         # see if this node contains any namespace declarations that are relevant
  29         # for us
  30         my $attrs = $node->getAttributes;
  31         if (defined($attrs)) {
  32                 for my $attr ($attrs->getValues) {
  33                         my $name = $attr->getName;
  34                         if ($name =~ /^xmlns:(.*)$/) {
  35                                 $nsup->declare_prefix($1, $attr->getValue);
  36                                 $node->removeAttribute($name) if ($clean);
  37                         }
  38                 }
  39         }
  40
  41         if (!ref($obj)) {                                                       # overwrite
  42                 for my $child ($node->getChildNodes) {
  43                         $node->removeChild($child);
  44                 }
  45                 $node->addText($obj);
  46         } elsif (Scalar::Util::blessed($obj) && $obj->isa('XML::DOM::Node')) {  # overwrite
  47                 for my $child ($node->getChildNodes) {
  48                         $node->removeChild($child);
  49                 }
  50
  51                 if ($obj->isa('XML::DOM::Document')) {
  52                         $obj = $obj->getDocumentElement;
  53                 }
  54
  55                 my $newobj = $obj->cloneNode(1);
  56                 if ($node->isa('XML::DOM::Document')) {
  57                         $newobj->setOwnerDocument($node);
  58                 } else {
  59                         $newobj->setOwnerDocument($node->getOwnerDocument);
  60                 }
  61                 $node->appendChild($newobj);
  62         } elsif (ref($obj) eq 'HASH') {                                         # substitute
  63                 for my $child ($node->getChildNodes) {
  64                         my $processed = 0;
  65
  66                         if ($child->getNodeType == XML::DOM::ELEMENT_NODE) {
  67                                 my (undef, undef, $tag) = $nsup->process_element_name($child->getTagName);
  68
  69                                 my $id;
  70                                 my $attrs = $child->getAttributes;
  71                                 if (defined($attrs)) {
  72                                         for my $attr ($attrs->getValues) {
  73                                                 next if ($attr->getName =~ /^xmlns(:|$)/);
  74
  75                                                 my ($nsuri, undef, $tag) = $nsup->process_attribute_name($attr->getName);
  76                                                 if ($nsuri eq 'http://template.sesse.net/' && $tag eq 'id') {
  77                                                         $id = $attr->getValue;
  78                                                         $child->removeAttribute($attr->getName) if ($clean);
  79                                                 }
  80                                         }
  81                                 }
  82
  83                                 # check all substitutions to see if we found anything
  84                                 # appropriate
  85                                 for my $key (keys %$obj) {
  86                                         if (($key =~ /^\Q$tag\E\/(.*)$/) ||
  87                                             (defined($id) && $key =~ /^#\Q$id\E\/(.*)$/)) {
  88                                                 $child->setAttribute($1, $obj->{$key});
  89                                         }
  90
  91                                         next if ($processed);
  92                                         if ($key eq $tag || (defined($id) && $key eq ('#'.$id))) {
  93                                                 process($child, $obj->{$key}, $clean, $nsup);
  94                                                 $processed = 1;
  95                                         }
  96                                 }
  97                         }
  98
  99                         process($child, $obj, $clean, $nsup) unless ($processed);
 100                 }
 101         } elsif (ref($obj) eq 'ARRAY') {                                        # repeat
 102                 my $doc = $node->getOwnerDocument;
 103                 my $frag = $doc->createDocumentFragment;
 104
 105                 for my $child ($node->getChildNodes) {
 106                         $frag->appendChild($child);
 107                 }
 108                 for my $child ($node->getChildNodes) {
 109                         $node->removeChild($child);
 110                 }
 111
 112                 for my $instance (@$obj) {
 113
 114                         my $newnode = $frag->cloneNode(1);
 115                         process($newnode, $instance, $clean, $nsup);
 116                         $node->appendChild($newnode);
 117                         clean($newnode, $nsup) if ($clean);
 118                 }
 119
 120                 $frag->dispose;
 121                 $nsup->pop_context;
 122                 return;
 123         }
 124
 125         clean($node, $nsup) if $clean;
 126         $nsup->pop_context;
 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;