git.sesse.net Git - wloh/blob - include/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
  49                 process($newobj, {}, $clean, $nsup);
  50         } elsif (ref($obj) eq 'HASH') {                                         # substitute
  51                 for my $child ($node->getChildNodes) {
  52                         my $processed = 0;
  53                         $nsup->push_context;
  54
  55                         if ($child->getNodeType == XML::DOM::ELEMENT_NODE) {
  56                                 # see if this node contains any namespace declarations that are relevant
  57                                 # for us
  58                                 my $attrs = $child->getAttributes;
  59                                 if (defined($attrs)) {
  60                                         for my $attr ($attrs->getValues) {
  61                                                 my $name = $attr->getName;
  62                                                 if ($name =~ /^xmlns:(.*)$/) {
  63                                                         $nsup->declare_prefix($1, $attr->getValue);
  64                                                         $child->removeAttribute($name) if ($clean);
  65                                                 }
  66                                         }
  67                                 }
  68
  69                                 my (undef, undef, $tag) = $nsup->process_element_name($child->getTagName);
  70
  71                                 my $id;
  72                                 my $attrs = $child->getAttributes;
  73                                 if (defined($attrs)) {
  74                                         for my $attr ($attrs->getValues) {
  75                                                 next if ($attr->getName =~ /^xmlns(:|$)/);
  76
  77                                                 my ($nsuri, undef, $tag) = $nsup->process_attribute_name($attr->getName);
  78                                                 if ($nsuri eq 'http://template.sesse.net/' && $tag eq 'id') {
  79                                                         $id = $attr->getValue;
  80                                                         $child->removeAttribute($attr->getName) if ($clean);
  81                                                 }
  82                                         }
  83                                 }
  84
  85                                 # check all substitutions to see if we found anything
  86                                 # appropriate
  87                                 for my $key (keys %$obj) {
  88                                         if (($key =~ /^\Q$tag\E\/(.*)$/) ||
  89                                             (defined($id) && $key =~ /^#\Q$id\E\/(.*)$/)) {
  90                                                 $child->setAttribute($1, $obj->{$key});
  91                                         }
  92
  93                                         next if ($processed);
  94                                         if ($key eq $tag || (defined($id) && $key eq ('#'.$id))) {
  95                                                 process($child, $obj->{$key}, $clean, $nsup);
  96                                                 $processed = 1;
  97                                         }
  98                                 }
  99                         }
 100
 101                         process($child, $obj, $clean, $nsup) unless ($processed);
 102                         $nsup->pop_context;
 103                 }
 104         } elsif (ref($obj) eq 'ARRAY') {                                        # repeat
 105                 my $doc = $node->getOwnerDocument;
 106                 my $frag = $doc->createDocumentFragment;
 107
 108                 for my $child ($node->getChildNodes) {
 109                         $frag->appendChild($child);
 110                 }
 111                 for my $child ($node->getChildNodes) {
 112                         $node->removeChild($child);
 113                 }
 114
 115                 for my $instance (@$obj) {
 116                         next if (!defined($instance));
 117
 118                         my $newnode = $frag->cloneNode(1);
 119                         process($newnode, $instance, $clean, $nsup);
 120                         $node->appendChild($newnode);
 121                         clean($newnode, $nsup) if ($clean);
 122                 }
 123
 124                 $frag->dispose;
 125         }
 126
 127         clean($node, $nsup) if $clean;
 128 }
 129
 130 sub clean {
 131         my ($node, $nsup) = @_;
 132
 133         if ($node->getNodeType == XML::DOM::ELEMENT_NODE) {
 134                 my ($nsuri) = $nsup->process_element_name($node->getTagName);
 135                 return unless ($nsuri eq 'http://template.sesse.net/');
 136
 137                 # as this is a dummy node, we want to remove it and move everything further up
 138                 # after we've done any required replacements
 139                 my $doc = $node->getOwnerDocument;
 140                 my $frag = $doc->createDocumentFragment;
 141
 142                 for my $child ($node->getChildNodes) {
 143                         $frag->appendChild($child);
 144                 }
 145                 for my $child ($node->getChildNodes) {
 146                         $node->removeChild($child);
 147                 }
 148
 149                 my $parent = $node->getParentNode;
 150
 151                 $parent->replaceChild($frag, $node);
 152         }
 153 }
 154
 155 sub alternate {
 156         my ($tag, $array, @elems) = @_;
 157
 158         my $i = 0;
 159         my $num = scalar @elems;
 160
 161         for my $ref (@$array) {
 162                 if (defined($ref)) {
 163                         $ref->{$tag} = $elems[$i++ % $num];
 164                 }
 165         }
 166
 167         return $array;
 168 }
 169
 170 1;