lib/ZOOM/IRSpy/Record.pm

   1 # $Id: Record.pm,v 1.11 2006-09-25 12:39:34 mike Exp $
   2
   3 package ZOOM::IRSpy::Record;
   4
   5 use 5.008;
   6 use strict;
   7 use warnings;
   8
   9 use XML::LibXML;
  10 use XML::LibXML::XPathContext;
  11
  12
  13 =head1 NAME
  14
  15 ZOOM::IRSpy::Record - record describing a target for IRSpy
  16
  17 =head1 SYNOPSIS
  18
  19  ## To follow
  20
  21 =head1 DESCRIPTION
  22
  23 I<## To follow>
  24
  25 =cut
  26
  27 sub new {
  28     my $class = shift();
  29     my($target, $zeerex) = @_;
  30
  31     if (!defined $zeerex) {
  32         $zeerex = _empty_zeerex_record($target);
  33     }
  34
  35     my $parser = new XML::LibXML();
  36     return bless {
  37         target => $target,
  38         parser => $parser,
  39         zeerex => $parser->parse_string($zeerex)->documentElement(),
  40     }, $class;
  41 }
  42
  43
  44 sub _empty_zeerex_record {
  45     my($target) = @_;
  46
  47     ### Doesn't recognise SRU/SRW URLs
  48     my($host, $port, $db) = ZOOM::IRSpy::_parse_target_string($target);
  49
  50     my $xhost = xml_encode($host);
  51     my $xport = xml_encode($port);
  52     my $xdb = xml_encode($db);
  53     return <<__EOT__;
  54 <explain xmlns="http://explain.z3950.org/dtd/2.0/">
  55  <serverInfo protocol="Z39.50" version="1995">
  56   <host>$xhost</host>
  57   <port>$xport</port>
  58   <database>$xdb</database>
  59  </serverInfo>
  60 </explain>
  61 __EOT__
  62 }
  63
  64
  65 # I can't -- just can't, can't, can't -- believe that this function
  66 # isn't provided by one of the core XML modules.  But the evidence all
  67 # says that it's not: among other things, XML::Generator and
  68 # Template::Plugin both roll their own.  So I will do likewise.  D'oh!
  69 #
  70 sub xml_encode {
  71     my ($text) = @_;
  72     $text =~ s/&/&amp;/g;
  73     $text =~ s/</&lt;/g;
  74     $text =~ s/>/&gt;/g;
  75     $text =~ s/['']/&apos;/g;
  76     $text =~ s/[""]/&quot;/g;
  77     return $text;
  78 }
  79
  80
  81 sub append_entry {
  82     my $this = shift();
  83     my($xpath, $frag) = @_;
  84
  85     #print STDERR "this=$this, xpath='$xpath', frag='$frag'\n";
  86     my $root = $this->{zeerex}; # XML::LibXML::Element ISA XML::LibXML::Node
  87     my $xc = XML::LibXML::XPathContext->new($root);
  88     $xc->registerNs(zeerex => "http://explain.z3950.org/dtd/2.0/");
  89     $xc->registerNs(irspy => "http://indexdata.com/irspy/1.0");
  90
  91     my @nodes = $xc->findnodes($xpath);
  92     if (@nodes == 0) {
  93         # Make the node that we're inserting into, if possible.  A
  94         # fully general version would work its way through each
  95         # component of the XPath, but for now we just treat it as a
  96         # single chunk to go inside the top-level node.
  97         $this->_half_decent_appendWellBalancedChunk($root,
  98                                                     "<$xpath></$xpath>");
  99         @nodes = $xc->findnodes($xpath);
 100         die("still no matches for '$xpath' after creating: can't append")
 101             if @nodes == 0;
 102     }
 103
 104     ZOOM::Log::log("irspy",
 105                    scalar(@nodes), " matches for '$xpath': using first")
 106         if @nodes > 1;
 107
 108     $this->_half_decent_appendWellBalancedChunk($nodes[0], $frag);
 109 }
 110
 111
 112 # *sigh*
 113 #
 114 # _Clearly_ the right way to append a well-balanced chunk of XML to
 115 # a node's children is to call appendWellBalancedChunk() from the
 116 # XML::LibXML::Element class.  However, this fails in the common case
 117 # where the ZeeRex record we're working with doesn't declare the
 118 # "irspy" namespace that the inserted fragments use.
 119 #
 120 # To my utter astonishment it seems that XML::LibXML (as of version
 121 # 1.58, 31st March 2004) doesn't provide ANY way to register a
 122 # namespace for parsing, which makes the parse_balanced_chunk()
 123 # function that appendWellBalancedChunk() uses effectively useless.
 124 # It _is_ possible to use setNamespace() on a node, to register a new
 125 # namespace mapping for that node -- but that only affects pre-parsed
 126 # trees, and is no use for parsing.  Hence the following pair of lines
 127 # DOES NOT WORK:
 128 #       $node->setNamespace("http://indexdata.com/irspy/1.0", "irspy", 0);
 129 #       $node->appendWellBalancedChunk($frag);
 130 #
 131 # Instead I have to go the long way round, hence this method.  I have
 132 # two candidate re-implementations, of which the former is marginally
 133 # less loathsome, but does require that the excess namespace
 134 # declarations be factored out later -- as least, if you want neat
 135 # output.
 136 #
 137 sub _half_decent_appendWellBalancedChunk {
 138     my $this = shift();
 139     my($node, $frag) = @_;
 140
 141     if (1) {
 142         $frag =~ s,>, xmlns:irspy="http://indexdata.com/irspy/1.0">,;
 143         $node->appendWellBalancedChunk($frag);
 144         return;
 145     }
 146
 147     # Instead -- and to call this brain-damaged would be an insult
 148     # to all those fine people out there with actual brain damage
 149     # -- I have to "parse" the XML fragment myself and insert the
 150     # resulting hand-build DOM tree.  Someone shoot me now.
 151     my($open, $content, $close) = $frag =~ /^<(.*?)>(.*)<\/(.*?)>$/;
 152     die "can't 'parse' XML fragment '$frag'"
 153         if !defined $open;
 154     my($tag, $attrs) = $open =~ /(.*?)\s(.*)/;
 155     $tag = $open if !defined $tag;
 156     die "mismatched XML start/end <$open>...<$close>"
 157         if $close ne $tag;
 158     print STDERR "tag='$tag', attrs=[$attrs], content='$content'\n";
 159     die "## no code yet to make DOM node";
 160 }
 161
 162
 163 =head1 SEE ALSO
 164
 165 ZOOM::IRSpy
 166
 167 =head1 AUTHOR
 168
 169 Mike Taylor, E<lt>mike@indexdata.comE<gt>
 170
 171 =head1 COPYRIGHT AND LICENSE
 172
 173 Copyright (C) 2006 by Index Data ApS.
 174
 175 This library is free software; you can redistribute it and/or modify
 176 it under the same terms as Perl itself, either Perl version 5.8.7 or,
 177 at your option, any later version of Perl 5 you may have available.
 178
 179 =cut
 180
 181 1;