lib/ZOOM/IRSpy/Utils.pm

   1 # $Id: Utils.pm,v 1.15 2006-11-16 17:18:14 mike Exp $
   2
   3 package ZOOM::IRSpy::Utils;
   4
   5 use 5.008;
   6 use strict;
   7 use warnings;
   8
   9 use Exporter 'import';
  10 our @EXPORT_OK = qw(xml_encode
  11                     cql_quote
  12                     cql_target
  13                     irspy_xpath_context
  14                     modify_xml_document);
  15
  16 use XML::LibXML;
  17 use XML::LibXML::XPathContext;
  18
  19 our $IRSPY_NS = 'http://indexdata.com/irspy/1.0';
  20
  21
  22 # Utility functions follow, exported for use of web UI
  23
  24 # I can't -- just can't, can't, can't -- believe that this function
  25 # isn't provided by one of the core XML modules.  But the evidence all
  26 # says that it's not: among other things, XML::Generator and
  27 # Template::Plugin both roll their own.  So I will do likewise.  D'oh!
  28 #
  29 sub xml_encode {
  30     my($text, $fallback) = @_;
  31
  32     $text = $fallback if !defined $text;
  33     use Carp;
  34     confess "xml_encode(): text and fallback both undefined"
  35         if !defined $text;
  36
  37     $text =~ s/&/&amp;/g;
  38     $text =~ s/</&lt;/g;
  39     $text =~ s/>/&gt;/g;
  40     $text =~ s/['']/&apos;/g;
  41     $text =~ s/[""]/&quot;/g;
  42     return $text;
  43 }
  44
  45
  46 # Quotes a term for use in a CQL query
  47 sub cql_quote {
  48     my($term) = @_;
  49
  50     $term =~ s/([""\\])/\\$1/g;
  51     $term = qq["$term"] if $term =~ /\s/;
  52     return $term;
  53 }
  54
  55
  56 # Makes a CQL query that finds a specified target
  57 sub cql_target {
  58     my($host, $port, $db) = @_;
  59
  60     return ("host=" . cql_quote($host) . " and " .
  61             "port=" . cql_quote($port) . " and " .
  62             "path=" . cql_quote($db));
  63 }
  64
  65
  66 # PRIVATE to irspy_namespace() and irspy_xpath_context()
  67 my %_namespaces = (
  68                    e => 'http://explain.z3950.org/dtd/2.0/',
  69                    i => $IRSPY_NS,
  70                    );
  71
  72
  73 sub irspy_namespace {
  74     my($prefix) = @_;
  75
  76     use Carp;
  77     confess "irspy_namespace(undef)" if !defined $prefix;
  78     my $uri = $_namespaces{$prefix};
  79     die "irspy_namespace(): no URI for namespace prefix '$prefix'"
  80         if !defined $uri;
  81
  82     return $uri;
  83 }
  84
  85
  86 sub irspy_xpath_context {
  87     my($record) = @_;
  88
  89     my $xml = ref $record ? $record->render() : $record;
  90     my $parser = new XML::LibXML();
  91     my $doc = $parser->parse_string($xml);
  92     my $root = $doc->getDocumentElement();
  93     my $xc = XML::LibXML::XPathContext->new($root);
  94     foreach my $prefix (keys %_namespaces) {
  95         $xc->registerNs($prefix, $_namespaces{$prefix});
  96     }
  97     return $xc;
  98 }
  99
 100
 101 sub modify_xml_document {
 102     my($xc, $fieldsByKey, $data) = @_;
 103
 104     my $nchanges = 0;
 105     foreach my $key (keys %$data) {
 106         my $value = $data->{$key};
 107         my $ref = $fieldsByKey->{$key} or die "no field '$key'";
 108         my($name, $nlines, $caption, $xpath, @addAfter) = @$ref;
 109         #print "Considering $key='$value' ($xpath)<br/>\n";
 110         my @nodes = $xc->findnodes($xpath);
 111         if (@nodes) {
 112             warn scalar(@nodes), " nodes match '$xpath'" if @nodes > 1;
 113             my $node = $nodes[0];
 114
 115             if ($node->isa("XML::LibXML::Attr")) {
 116                 if ($value ne $node->getValue()) {
 117                     $node->setValue($value);
 118                     $nchanges++;
 119                     #print "Attr $key: '", $node->getValue(), "' -> '$value' ($xpath)<br/>\n";
 120                 }
 121             } elsif ($node->isa("XML::LibXML::Element")) {
 122                 # The contents could be any mixture of text and
 123                 # comments and maybe even other crud such as processing
 124                 # instructions.  The simplest thing is just to throw it all
 125                 # away and start again, making a single Text node the
 126                 # canonical representation.  But before we do that,
 127                 # we'll check whether the element is already
 128                 # canonical, to determine whether our change is a
 129                 # no-op.
 130                 my $old = "???";
 131                 my @children = $node->childNodes();
 132                 if (@children == 1) {
 133                     my $child = $node->firstChild();
 134                     if (ref $child && ref $child eq "XML::LibXML::Text") {
 135                         $old = $child->getData();
 136                         next if $value eq $old;
 137                     }
 138                 }
 139
 140                 $node->removeChildNodes();
 141                 my $child = new XML::LibXML::Text($value);
 142                 $node->appendChild($child);
 143                 $nchanges++;
 144                 #print "Elem $key: '$old' -> '$value' ($xpath)<br/>\n";
 145             } else {
 146                 warn "unexpected node type $node";
 147             }
 148
 149         } else {
 150             next if !$value; # No need to create a new empty node
 151             my($ppath, $selector) = $xpath =~ /(.*)\/(.*)/;
 152             dom_add_node($xc, $ppath, $selector, $value, @addAfter);
 153             #print "New $key ($xpath) = '$value'<br/>\n";
 154             $nchanges++;
 155         }
 156     }
 157
 158     return $nchanges;
 159 }
 160
 161
 162 sub dom_add_node {
 163     my($xc, $ppath, $selector, $value, @addAfter) = @_;
 164
 165     #print "Adding $selector='$value' at '$ppath' after (", join(", ", map { "'$_'" } @addAfter), ")<br/>\n";
 166     my $node = find_or_make_node($xc, $ppath, 0);
 167     die "couldn't find or make node '$node'" if !defined $node;
 168
 169     my $is_attr = ($selector =~ s/^@//);
 170     my(undef, $prefix, $simpleSel) = $selector =~ /((.*?):)?(.*)/;
 171     #warn "selector='$selector', prefix='$prefix', simpleSel='$simpleSel'";
 172     if ($is_attr) {
 173         if (defined $prefix) {
 174             ### This seems to no-op (thank, DOM!) but I have have no
 175             # idea, and it's not needed for IRSpy, so I am not going
 176             # to debug it now.
 177             $node->setAttributeNS(irspy_namespace($prefix),
 178                                   $simpleSel, $value);
 179         } else {
 180             $node->setAttribute($simpleSel, $value);
 181         }
 182         return;
 183     }
 184
 185     my $new = new XML::LibXML::Element($simpleSel);
 186     $new->setNamespace(irspy_namespace($prefix), $prefix)
 187         if defined $prefix;
 188
 189     $new->appendText($value);
 190     foreach my $predecessor (reverse @addAfter) {
 191         my($child) = $xc->findnodes($predecessor, $node);
 192         if (defined $child) {
 193             $node->insertAfter($new, $child);
 194             #warn "Added after '$predecessor'";
 195             return;
 196         }
 197     }
 198
 199     # Didn't find any of the nodes that are supposed to precede the
 200     # new one, so we need to insert the new node as the first of the
 201     # parent's children.  However *sigh* there is no prependChild()
 202     # analogous to appendChild(), so we have to go the long way round.
 203     my @children = $node->childNodes();
 204     if (@children) {
 205         $node->insertBefore($new, $children[0]);
 206         #warn "Added new first child";
 207     } else {
 208         $node->appendChild($new);
 209         #warn "Added new only child";
 210     }
 211
 212     if (0) {
 213         my $text = xml_encode(inheritance_tree($xc));
 214         $text =~ s/\n/<br\/>$&/sg;
 215         print "<pre>$text</pre>\n";
 216     }
 217 }
 218
 219
 220 sub find_or_make_node {
 221     my($xc, $path, $recursion_level) = @_;
 222
 223     die "deep recursion in find_or_make_node($path)"
 224         if $recursion_level == 10;
 225     $path = "." if $path eq "";
 226
 227     my @nodes = $xc->findnodes($path);
 228     if (@nodes == 0) {
 229         # Oh dear, the parent node doesn't exist.  We could make it,
 230         my(undef, $ppath, $element) = $path =~ /((.*)\/)?(.*)/;
 231         $ppath = "" if !defined $ppath;
 232         #warn "path='$path', ppath='$ppath', element='$element'";
 233         #warn "no node '$path': making it";
 234         my $parent = find_or_make_node($xc, $ppath, $recursion_level-1);
 235
 236         my(undef, $prefix, $nsElem) = $element =~ /((.*?):)?(.*)/;
 237         #warn "element='$element', prefix='$prefix', nsElem='$nsElem'";
 238         my $new = new XML::LibXML::Element($nsElem);
 239         if (defined $prefix) {
 240             #warn "setNamespace($prefix)";
 241             $new->setNamespace(irspy_namespace($prefix), $prefix);
 242         }
 243
 244         $parent->appendChild($new);
 245         return $new;
 246     }
 247     warn scalar(@nodes), " nodes match parent '$path'" if @nodes > 1;
 248     return $nodes[0];
 249 }
 250
 251
 252 sub inheritance_tree {
 253     my($type, $level) = @_;
 254     $level = 0 if !defined $level;
 255     return "Woah!  Too deep, man!\n" if $level > 20;
 256
 257     $type = ref $type if ref $type;
 258     my $text = "";
 259     $text = "--> " if $level == 0;
 260     $text .= ("\t" x $level) . "$type\n";
 261     my @ISA = eval "\@${type}::ISA";
 262     foreach my $superclass (@ISA) {
 263         $text .= inheritance_tree($superclass, $level+1);
 264     }
 265
 266     return $text;
 267 }
 268
 269
 270 #print "Loaded ZOOM::IRSpy::Utils.pm";
 271
 272
 273 1;