lib/ZOOM/IRSpy/Utils.pm

   1
   2 package ZOOM::IRSpy::Utils;
   3
   4 use 5.008;
   5 use strict;
   6 use warnings;
   7
   8 use Scalar::Util;
   9
  10 use Exporter 'import';
  11 our @EXPORT_OK = qw(utf8param
  12                     trimField
  13                     utf8paramTrim
  14                     isodate
  15                     xml_encode
  16                     cql_quote
  17                     cql_target
  18                     irspy_xpath_context
  19                     irspy_make_identifier
  20                     irspy_record2identifier
  21                     irspy_identifier2target
  22                     modify_xml_document
  23                     bib1_access_point
  24                     render_record
  25                     validate_record
  26                     calc_reliability_string
  27                     calc_reliability_stats);
  28
  29 use XML::LibXML;
  30 use XML::LibXML::XPathContext;
  31 use Encode;
  32 use Encode qw(is_utf8);
  33
  34
  35 our $IRSPY_NS = 'http://indexdata.com/irspy/1.0';
  36
  37 # Under Apache 2/mod_perl 2, the ubiquitous $r is no longer and
  38 # Apache::Request object, nor even an Apache2::Request, but an
  39 # Apache2::RequestReq ... which, astonishingly, doesn't have the
  40 # param() method.  So if we're given one of these things, we need to
  41 # make an Apache::Request out of, which at least isn't too hard.
  42 # However *sigh* this may not be a cheap operation, so we keep a cache
  43 # of already-made Request objects.
  44 #
  45 my %_apache2request;
  46 my %_paramsbyrequest;           # Used for Apache2 only
  47 sub utf8param {
  48     my($r, $key, $value) = @_;
  49
  50     if ($r->isa('Apache2::RequestRec')) {
  51         # Running under Apache2
  52         if (defined $_apache2request{$r}) {
  53             #warn "using existing Apache2::RequestReq for '$r'";
  54             $r = $_apache2request{$r};
  55         } else {
  56             require Apache2::Request;
  57             #warn "making new Apache2::RequestReq for '$r'";
  58             $r = $_apache2request{$r} = new Apache2::Request($r);
  59         }
  60     }
  61
  62     if (!defined $key) {
  63         return map { decode_utf8($_) } $r->param();
  64     }
  65
  66     my $raw = undef;
  67     $raw = $_paramsbyrequest{$r}->{$key} if $r->isa('Apache2::Request');
  68     $raw = $r->param($key) if !defined $raw;
  69
  70     if (defined $value) {
  71         # Argh!  Simply writing through to the underlying method
  72         # param() won't work in Apache2, where param() is readonly.
  73         # So we have to keep a hash of additional values, which we
  74         # consult (above) before the actual parameters.  Ouch ouch.
  75         if ($r->isa('Apache2::Request')) {
  76             $_paramsbyrequest{$r}->{$key} = encode_utf8($value);
  77         } else {
  78             $r->param($key, encode_utf8($value));
  79         }
  80     }
  81
  82     return undef if !defined $raw;
  83     my $cooked = decode_utf8($raw);
  84     warn "converted '$raw' to '", $cooked, "'\n" if $cooked ne $raw;
  85     return $cooked;
  86 }
  87
  88 # Utility functions follow, exported for use of web UI
  89 sub utf8param_apache1 {
  90     my($r, $key, $value) = @_;
  91     die "utf8param() called with value '$value'" if defined $value;
  92
  93     my $raw = $r->param($key);
  94     return undef if !defined $raw;
  95     my $cooked = decode_utf8($raw);
  96     warn "converted '$raw' to '", $cooked, "'\n" if $cooked ne $raw;
  97     return $cooked;
  98 }
  99
 100
 101 sub isodate {
 102     my($time) = @_;
 103
 104     my($sec, $min, $hour, $mday, $mon, $year) = localtime($time);
 105     return sprintf("%04d-%02d-%02dT%02d:%02d:%02d",
 106                    $year+1900, $mon+1, $mday, $hour, $min, $sec);
 107 }
 108
 109 # strips whitespaces at start and ends of a field
 110 sub trimField {
 111     my $field  = shift;
 112
 113     $field =~ s/^\s+//;
 114     $field =~ s/\s+$//;
 115
 116     return $field;
 117 }
 118
 119 # utf8param() with trim
 120 sub utf8paramTrim {
 121     my $result = utf8param(@_);
 122
 123     if (defined $result) {
 124         $result = trimField($result);
 125     }
 126
 127     return $result;
 128 }
 129
 130 # I can't -- just can't, can't, can't -- believe that this function
 131 # isn't provided by one of the core XML modules.  But the evidence all
 132 # says that it's not: among other things, XML::Generator and
 133 # Template::Plugin both roll their own.  So I will do likewise.  D'oh!
 134 #
 135 sub xml_encode {
 136     my($text, $fallback, $opts) = @_;
 137     if (!defined $opts && ref $fallback) {
 138         # The second and third arguments are both optional
 139         $opts = $fallback;
 140         $fallback = undef;
 141     }
 142     $opts = {} if !defined $opts;
 143
 144     $text = $fallback if !defined $text;
 145     use Carp;
 146     confess "xml_encode(): text and fallback both undefined"
 147         if !defined $text;
 148
 149     $text =~ s/&/&amp;/g;
 150     $text =~ s/</&lt;/g;
 151     $text =~ s/>/&gt;/g;
 152     # Internet Explorer can't display &apos; (!) so don't create it
 153     #$text =~ s/['']/&apos;/g;
 154     $text =~ s/[""]/&quot;/g;
 155     $text =~ s/ /&nbsp;/g if $opts->{nbsp};
 156
 157     return $text;
 158 }
 159
 160
 161 # Quotes a term for use in a CQL query
 162 sub cql_quote {
 163     my($term) = @_;
 164
 165     $term =~ s/([""\\*?])/\\$1/g;
 166     $term = qq["$term"] if $term =~ /[\s""\/\\]/;
 167     return $term;
 168 }
 169
 170
 171 # Makes a CQL query that finds a specified target.  Arguments may be
 172 # either an ID alone, or a (host, port, db) triple.
 173 sub cql_target {
 174     my($protocol, $host, $port, $db) = @_;
 175
 176     my $id;
 177     if (defined $host) {
 178         $id = irspy_make_identifier($protocol, $host, $port, $db);
 179     } else {
 180         $id = $protocol;
 181     }
 182
 183     return "rec.id==" . cql_quote($id);
 184 }
 185
 186
 187 # PRIVATE to irspy_namespace() and irspy_xpath_context()
 188 my %_namespaces = (
 189                    e => 'http://explain.z3950.org/dtd/2.0/',
 190                    i => $IRSPY_NS,
 191                    );
 192
 193
 194 sub irspy_namespace {
 195     my($prefix) = @_;
 196
 197     use Carp;
 198     confess "irspy_namespace(undef)" if !defined $prefix;
 199     my $uri = $_namespaces{$prefix};
 200     die "irspy_namespace(): no URI for namespace prefix '$prefix'"
 201         if !defined $uri;
 202
 203     return $uri;
 204 }
 205
 206
 207 sub irspy_xpath_context {
 208     my($record) = @_;
 209
 210     if (ref $record && $record->isa("ZOOM::Record")) {
 211         $record = $record->render();
 212     }
 213
 214     my $root;
 215     if (ref $record) {
 216         $root = $record;
 217     } else {
 218         my $parser = new XML::LibXML();
 219         my $doc = $parser->parse_string($record);
 220         $root = $doc->getDocumentElement();
 221     }
 222
 223     my $xc = XML::LibXML::XPathContext->new($root);
 224     foreach my $prefix (keys %_namespaces) {
 225         $xc->registerNs($prefix, $_namespaces{$prefix});
 226     }
 227     return $xc;
 228 }
 229
 230
 231 # Construct an opaque identifier from its components.  Although it's
 232 # trivial, this is needed in so many places that it really needs to be
 233 # factored out.
 234 #
 235 # This is the converse of _parse_target_string() in IRSpy.pm, which
 236 # should be renamed and moved into this package.
 237 #
 238 sub irspy_make_identifier {
 239     my($protocol, $host, $port, $dbname) = @_;
 240
 241     die "irspy_make_identifier(" . join(", ", map { "'$_'" } @_).
 242         "): wrong number of arguments" if @_ != 4;
 243
 244     die "irspy_make_identifier(): protocol undefined" if !defined $protocol;
 245     die "irspy_make_identifier(): host undefined" if !defined $host;
 246     die "irspy_make_identifier(): port undefined" if !defined $port;
 247     die "irspy_make_identifier(): dbname undefined" if !defined $dbname;
 248
 249     return "$protocol:$host:$port/$dbname";
 250 }
 251
 252
 253 # Returns the opaque identifier of an IRSpy record based on the
 254 # XPathContext'ed DOM object, as returned by irspy_xpath_context().
 255 # This is doing the same thing as irspy_make_identifier() but from a
 256 # record rather than a set of parameters.
 257 #
 258 sub irspy_record2identifier {
 259     my($xc) = @_;
 260
 261     ### Must be kept the same as is used in ../../../zebra/*.xsl
 262     return $xc->find("concat(e:serverInfo/\@protocol, ':',
 263                              e:serverInfo/e:host, ':',
 264                              e:serverInfo/e:port, '/',
 265                              e:serverInfo/e:database)");
 266 }
 267
 268
 269 # Transforms an IRSpy opqaue identifier, as returned from
 270 # irspy_make_identifier() or irspy_record2identifier(), into a YAZ
 271 # target-string suitable for feeding to ZOOM.  Before we introduced
 272 # the protocol element at the start of the identifier string, this was
 273 # a null transform; now we have to be a bit cleverer.
 274 #
 275 sub irspy_identifier2target {
 276     my $res = _irspy_identifier2target(@_);
 277     #carp "converted ID '@_' to target '$res'";
 278     return $res;
 279 }
 280
 281 sub _irspy_identifier2target {
 282     my($id) = @_;
 283
 284     confess "_irspy_identifier2target(): id is undefined"
 285         if !defined $id;
 286
 287     my($prefix, $protocol, $target) = ($id =~ /([^:]*,)?(.*?):(.*)/);
 288     $prefix ||= "";
 289     if (uc($protocol) eq "Z39.50" || uc($protocol) eq "TCP") {
 290         return "${prefix}tcp:$target";
 291     } elsif (uc($protocol) eq "SRU") {
 292         return "${prefix}sru=get,http:$target";
 293     } elsif (uc($protocol) eq "SRW") {
 294         return "${prefix}sru=srw,http:$target";
 295     }
 296
 297     warn "_irspy_identifier2target($id): unrecognised protocol '$protocol'";
 298     return $target;
 299 }
 300
 301
 302 # Modifies the XML document for which $xc is an XPath context by
 303 # inserting or replacing the values specified in the hash %$data.  The
 304 # keys are fieldnames, which are looked up in the register
 305 # $fieldsByKey to determine, among other things, what their XPath is.
 306
 307 sub modify_xml_document {
 308     my($xc, $fieldsByKey, $data) = @_;
 309
 310     my @changes = ();
 311     foreach my $key (keys %$data) {
 312         my $value = $data->{$key};
 313         my $ref = $fieldsByKey->{$key} or die "no field '$key'";
 314         my($name, $nlines, $caption, $xpath, @addAfter) = @$ref;
 315         #print "Considering $key='$value' ($xpath)<br/>\n";
 316         my @nodes = $xc->findnodes($xpath);
 317         if (@nodes) {
 318             warn scalar(@nodes), " nodes match '$xpath'" if @nodes > 1;
 319             my $node = $nodes[0];
 320
 321             if ($node->isa("XML::LibXML::Attr")) {
 322                 if ($value ne $node->getValue()) {
 323                     $node->setValue($value);
 324                     push @changes, $ref;
 325                     #print "Attr $key: '", $node->getValue(), "' -> '$value' ($xpath)<br/>\n";
 326                 }
 327             } elsif ($node->isa("XML::LibXML::Element")) {
 328                 # The contents could be any mixture of text and
 329                 # comments and maybe even other crud such as processing
 330                 # instructions.  The simplest thing is just to throw it all
 331                 # away and start again, making a single Text node the
 332                 # canonical representation.  But before we do that,
 333                 # we'll check whether the element is already
 334                 # canonical, to determine whether our change is a
 335                 # no-op.
 336                 my $old = "";
 337                 my @children = $node->childNodes();
 338                 if (@children == 1) {
 339                     my $child = $node->firstChild();
 340                     if (ref $child && ref $child eq "XML::LibXML::Text") {
 341                         $old = $child->getData();
 342                         #print STDERR "child='$child', old=", _renderchars($old), "\n" if $key eq "title";
 343                     }
 344                 }
 345                 next if $value eq $old;
 346
 347                 $node->removeChildNodes();
 348                 my $child = new XML::LibXML::Text($value);
 349                 $node->appendChild($child);
 350                 push @changes, $ref;
 351                 #print STDERR "Elem $key ($xpath): ", _renderchars($old), " -> '", _renderchars($value), "\n";
 352             } else {
 353                 warn "unexpected node type $node";
 354             }
 355
 356         } else {
 357             next if !defined $value; # No need to create a new empty node
 358             my($ppath, $selector) = $xpath =~ /(.*)\/(.*)/;
 359             dom_add_node($xc, $ppath, $selector, $value, @addAfter);
 360             #print "New $key ($xpath) = '$value'<br/>\n";
 361             push @changes, $ref;
 362         }
 363     }
 364
 365     return @changes;
 366 }
 367
 368
 369 sub _renderchars {
 370     my($text) = @_;
 371
 372     return "'" . $text . "'", " (", join(" ", map {ord($_)} split //, $text), "), is_utf8=" , is_utf8($text);
 373 }
 374
 375
 376 sub dom_add_node {
 377     my($xc, $ppath, $selector, $value, @addAfter) = @_;
 378
 379     #print "Adding $selector='$value' at '$ppath' after (", join(", ", map { "'$_'" } @addAfter), ")<br/>\n";
 380     my $node = find_or_make_node($xc, $ppath, 0);
 381     die "couldn't find or make node '$node'" if !defined $node;
 382
 383     my $is_attr = ($selector =~ s/^@//);
 384     my(undef, $prefix, $simpleSel) = $selector =~ /((.*?):)?(.*)/;
 385     #warn "selector='$selector', prefix='$prefix', simpleSel='$simpleSel'";
 386     if ($is_attr) {
 387         if (defined $prefix) {
 388             ### This seems to no-op (thank, DOM!) but I have have no
 389             # idea, and it's not needed for IRSpy, so I am not going
 390             # to debug it now.
 391             $node->setAttributeNS(irspy_namespace($prefix),
 392                                   $simpleSel, $value);
 393         } else {
 394             $node->setAttribute($simpleSel, $value);
 395         }
 396         return;
 397     }
 398
 399     my $new = new XML::LibXML::Element($simpleSel);
 400     $new->setNamespace(irspy_namespace($prefix), $prefix)
 401         if defined $prefix;
 402
 403     $new->appendText($value);
 404     foreach my $predecessor (reverse @addAfter) {
 405         my($child) = $xc->findnodes($predecessor, $node);
 406         if (defined $child) {
 407             $node->insertAfter($new, $child);
 408             #warn "Added after '$predecessor'";
 409             return;
 410         }
 411     }
 412
 413     # Didn't find any of the nodes that are supposed to precede the
 414     # new one, so we need to insert the new node as the first of the
 415     # parent's children.  However *sigh* there is no prependChild()
 416     # analogous to appendChild(), so we have to go the long way round.
 417     my @children = $node->childNodes();
 418     if (@children) {
 419         $node->insertBefore($new, $children[0]);
 420         #warn "Added new first child";
 421     } else {
 422         $node->appendChild($new);
 423         #warn "Added new only child";
 424     }
 425
 426     if (0) {
 427         my $text = xml_encode(inheritance_tree($xc));
 428         $text =~ s/\n/<br\/>$&/sg;
 429         print "<pre>$text</pre>\n";
 430     }
 431 }
 432
 433
 434 sub find_or_make_node {
 435     my($xc, $path, $recursion_level) = @_;
 436
 437     die "deep recursion in find_or_make_node($path)"
 438         if $recursion_level == 10;
 439     $path = "." if $path eq "";
 440
 441     my @nodes = $xc->findnodes($path);
 442     if (@nodes == 0) {
 443         # Oh dear, the parent node doesn't exist.  We could make it,
 444         my(undef, $ppath, $element) = $path =~ /((.*)\/)?(.*)/;
 445         $ppath = "" if !defined $ppath;
 446         #warn "path='$path', ppath='$ppath', element='$element'";
 447         #warn "no node '$path': making it";
 448         my $parent = find_or_make_node($xc, $ppath, $recursion_level-1);
 449
 450         my(undef, $prefix, $nsElem) = $element =~ /((.*?):)?(.*)/;
 451         #warn "element='$element', prefix='$prefix', nsElem='$nsElem'";
 452         my $new = new XML::LibXML::Element($nsElem);
 453         if (defined $prefix) {
 454             #warn "setNamespace($prefix)";
 455             $new->setNamespace(irspy_namespace($prefix), $prefix);
 456         }
 457
 458         $parent->appendChild($new);
 459         return $new;
 460     }
 461     warn scalar(@nodes), " nodes match parent '$path'" if @nodes > 1;
 462     return $nodes[0];
 463 }
 464
 465
 466 sub inheritance_tree {
 467     my($type, $level) = @_;
 468     $level = 0 if !defined $level;
 469     return "Woah!  Too deep, man!\n" if $level > 20;
 470
 471     $type = ref $type if ref $type;
 472     my $text = "";
 473     $text = "--> " if $level == 0;
 474     $text .= ("\t" x $level) . "$type\n";
 475     my @ISA = eval "\@${type}::ISA";
 476     foreach my $superclass (@ISA) {
 477         $text .= inheritance_tree($superclass, $level+1);
 478     }
 479
 480     return $text;
 481 }
 482
 483
 484 # This function is made available in xslt using the register_function call
 485 sub xslt_strcmp {
 486     my ($arg1, $arg2) = @_;
 487     return "$arg1" cmp "$arg2";
 488 }
 489
 490
 491 ### It feels like this should be in YAZ, exported via ZOOM-Perl.
 492 my %_bib1_access_point = (
 493         1 =>    "Personal name",
 494         2 =>    "Corporate name",
 495         3 =>    "Conference name",
 496         4 =>    "Title",
 497         5 =>    "Title series",
 498         6 =>    "Title uniform",
 499         7 =>    "ISBN",
 500         8 =>    "ISSN",
 501         9 =>    "LC card number",
 502         10 =>   "BNB card no.",
 503         11 =>   "BGF number",
 504         12 =>   "Local number",
 505         13 =>   "Dewey classification",
 506         14 =>   "UDC classification",
 507         15 =>   "Bliss classification",
 508         16 =>   "LC call number",
 509         17 =>   "NLM call number",
 510         18 =>   "NAL call number",
 511         19 =>   "MOS call number",
 512         20 =>   "Local classification",
 513         21 =>   "Subject heading",
 514         22 =>   "Subject Rameau",
 515         23 =>   "BDI index subject",
 516         24 =>   "INSPEC subject",
 517         25 =>   "MESH subject",
 518         26 =>   "PA subject",
 519         27 =>   "LC subject heading",
 520         28 =>   "RVM subject heading",
 521         29 =>   "Local subject index",
 522         30 =>   "Date",
 523         31 =>   "Date of publication",
 524         32 =>   "Date of acquisition",
 525         33 =>   "Title key",
 526         34 =>   "Title collective",
 527         35 =>   "Title parallel",
 528         36 =>   "Title cover",
 529         37 =>   "Title added title page",
 530         38 =>   "Title caption",
 531         39 =>   "Title running",
 532         40 =>   "Title spine",
 533         41 =>   "Title other variant",
 534         42 =>   "Title former",
 535         43 =>   "Title abbreviated",
 536         44 =>   "Title expanded",
 537         45 =>   "Subject precis",
 538         46 =>   "Subject rswk",
 539         47 =>   "Subject subdivision",
 540         48 =>   "No. nat'l biblio.",
 541         49 =>   "No. legal deposit",
 542         50 =>   "No. govt pub.",
 543         51 =>   "No. music publisher",
 544         52 =>   "Number db",
 545         53 =>   "Number local call",
 546         54 =>   "Code--language",
 547         55 =>   "Code--geographic area",
 548         56 =>   "Code--institution",
 549         57 =>   "Name and title *",
 550         58 =>   "Name geographic",
 551         59 =>   "Place publication",
 552         60 =>   "CODEN",
 553         61 =>   "Microform generation",
 554         62 =>   "Abstract",
 555         63 =>   "Note",
 556         1000 => "Author-title",
 557         1001 => "Record type",
 558         1002 => "Name",
 559         1003 => "Author",
 560         1004 => "Author-name personal",
 561         1005 => "Author-name corporate",
 562         1006 => "Author-name conference",
 563         1007 => "Identifier--standard",
 564         1008 => "Subject--LC children's",
 565         1009 => "Subject name -- personal",
 566         1010 => "Body of text",
 567         1011 => "Date/time added to db",
 568         1012 => "Date/time last modified",
 569         1013 => "Authority/format id",
 570         1014 => "Concept-text",
 571         1015 => "Concept-reference",
 572         1016 => "Any",
 573         1017 => "Server-choice",
 574         1018 => "Publisher",
 575         1019 => "Record-source",
 576         1020 => "Editor",
 577         1021 => "Bib-level",
 578         1022 => "Geographic-class",
 579         1023 => "Indexed-by",
 580         1024 => "Map-scale",
 581         1025 => "Music-key",
 582         1026 => "Related-periodical",
 583         1027 => "Report-number",
 584         1028 => "Stock-number",
 585         1030 => "Thematic-number",
 586         1031 => "Material-type",
 587         1032 => "Doc-id",
 588         1033 => "Host-item",
 589         1034 => "Content-type",
 590         1035 => "Anywhere",
 591         1036 => "Author-Title-Subject",
 592         1032 => "Doc-id (semantic definition change)",
 593         1037 => "SICI",
 594         1038 => "Abstract-language",
 595         1039 => "Application-kind",
 596         1040 => "Classification",
 597         1041 => "Classification-basic",
 598         1042 => "Classification-local-record",
 599         1043 => "Enzyme",
 600         1044 => "Possessing-institution",
 601         1045 => "Record-linking",
 602         1046 => "Record-status",
 603         1047 => "Treatment",
 604         1048 => "Control-number-GKD",
 605         1049 => "Control-number-linking",
 606         1050 => "Control-number-PND",
 607         1051 => "Control-number-SWD",
 608         1052 => "Control-number-ZDB",
 609         1053 => "Country-publication (country of Publication)",
 610         1054 => "Date-conference (meeting date)",
 611         1055 => "Date-record-status",
 612         1056 => "Dissertation-information",
 613         1057 => "Meeting-organizer",
 614         1058 => "Note-availability",
 615         1059 => "Number-CAS-registry (CAS registry number)",
 616         1060 => "Number-document (document number)",
 617         1061 => "Number-local-accounting",
 618         1062 => "Number-local-acquisition",
 619         1063 => "Number-local-call-copy-specific",
 620         1064 => "Number-of-reference (reference count)",
 621         1065 => "Number-norm",
 622         1066 => "Number-volume",
 623         1067 => "Place-conference (meeting location)",
 624         1068 => "Reference (references and footnotes)",
 625         1069 => "Referenced-journal (reference work)",
 626         1070 => "Section-code",
 627         1071 => "Section-heading",
 628         1072 => "Subject-GOO",
 629         1073 => "Subject-name-conference",
 630         1074 => "Subject-name-corporate",
 631         1075 => "Subject-genre/form",
 632         1076 => "Subject-name-geographical",
 633         1077 => "Subject--chronological",
 634         1078 => "Subject--title",
 635         1079 => "Subject--topical",
 636         1080 => "Subject-uncontrolled",
 637         1081 => "Terminology-chemical (chemical name)",
 638         1082 => "Title-translated",
 639         1083 => "Year-of-beginning",
 640         1084 => "Year-of-ending",
 641         1085 => "Subject-AGROVOC",
 642         1086 => "Subject-COMPASS",
 643         1087 => "Subject-EPT",
 644         1088 => "Subject-NAL",
 645         1089 => "Classification-BCM",
 646         1090 => "Classification-DB",
 647         1091 => "Identifier-ISRC",
 648         1092 => "Identifier-ISMN",
 649         1093 => "Identifier-ISRN",
 650         1094 => "Identifier-DOI",
 651         1095 => "Code-language-original",
 652         1096 => "Title-later",
 653         1097 => "DC-Title",
 654         1098 => "DC-Creator",
 655         1099 => "DC-Subject",
 656         1100 => "DC-Description",
 657         1101 => "DC-Publisher",
 658         1102 => "DC-Date",
 659         1103 => "DC-ResourceType",
 660         1104 => "DC-ResourceIdentifier",
 661         1105 => "DC-Language",
 662         1106 => "DC-OtherContributor",
 663         1107 => "DC-Format",
 664         1108 => "DC-Source",
 665         1109 => "DC-Relation",
 666         1110 => "DC-Coverage",
 667         1111 => "DC-RightsManagement",
 668         1112 => "Controlled Subject Index",
 669         1113 => "Subject Thesaurus",
 670         1114 => "Index Terms -- Controlled",
 671         1115 => "Controlled Term",
 672         1116 => "Spatial Domain",
 673         1117 => "Bounding Coordinates",
 674         1118 => "West Bounding Coordinate",
 675         1119 => "East Bounding Coordinate",
 676         1120 => "North Bounding Coordinate",
 677         1121 => "South Bounding Coordinate",
 678         1122 => "Place",
 679         1123 => "Place Keyword Thesaurus",
 680         1124 => "Place Keyword",
 681         1125 => "Time Period",
 682         1126 => "Time Period Textual",
 683         1127 => "Time Period Structured",
 684         1128 => "Beginning Date",
 685         1129 => "Ending Date",
 686         1130 => "Availability",
 687         1131 => "Distributor",
 688         1132 => "Distributor Name",
 689         1133 => "Distributor Organization",
 690         1134 => "Distributor Street Address",
 691         1135 => "Distributor City",
 692         1136 => "Distributor State or Province",
 693         1137 => "Distributor Zip or Postal Code",
 694         1138 => "Distributor Country",
 695         1139 => "Distributor Network Address",
 696         1140 => "Distributor Hours of Service",
 697         1141 => "Distributor Telephone",
 698         1142 => "Distributor Fax",
 699         1143 => "Resource Description",
 700         1144 => "Order Process",
 701         1145 => "Order Information",
 702         1146 => "Cost",
 703         1147 => "Cost Information",
 704         1148 => "Technical Prerequisites",
 705         1149 => "Available Time Period",
 706         1150 => "Available Time Textual",
 707         1151 => "Available Time Structured",
 708         1152 => "Available Linkage",
 709         1153 => "Linkage Type",
 710         1154 => "Linkage",
 711         1155 => "Sources of Data",
 712         1156 => "Methodology",
 713         1157 => "Access Constraints",
 714         1158 => "General Access Constraints",
 715         1159 => "Originator Dissemination Control",
 716         1160 => "Security Classification Control",
 717         1161 => "Use Constraints",
 718         1162 => "Point of Contact",
 719         1163 => "Contact Name",
 720         1164 => "Contact Organization",
 721         1165 => "Contact Street Address",
 722         1166 => "Contact City",
 723         1167 => "Contact State or Province",
 724         1168 => "Contact Zip or Postal Code",
 725         1169 => "Contact Country",
 726         1170 => "Contact Network Address",
 727         1171 => "Contact Hours of Service",
 728         1172 => "Contact Telephone",
 729         1173 => "Contact Fax",
 730         1174 => "Supplemental Information",
 731         1175 => "Purpose",
 732         1176 => "Agency Program",
 733         1177 => "Cross Reference",
 734         1178 => "Cross Reference Title",
 735         1179 => "Cross Reference Relationship",
 736         1180 => "Cross Reference Linkage",
 737         1181 => "Schedule Number",
 738         1182 => "Original Control Identifier",
 739         1183 => "Language of Record",
 740         1184 => "Record Review Date",
 741         1185 => "Performer",
 742         1186 => "Performer-Individual",
 743         1187 => "Performer-Group",
 744         1188 => "Instrumentation",
 745         1189 => "Instrumentation-Original",
 746         1190 => "Instrumentation-Current",
 747         1191 => "Arrangement",
 748         1192 => "Arrangement-Original",
 749         1193 => "Arrangement-Current",
 750         1194 => "Musical Key-Original",
 751         1195 => "Musical Key-Current",
 752         1196 => "Date-Composition",
 753         1197 => "Date-Recording",
 754         1198 => "Place-Recording",
 755         1199 => "Country-Recording",
 756         1200 => "Number-ISWC",
 757         1201 => "Number-Matrix",
 758         1202 => "Number-Plate",
 759         1203 => "Classification-McColvin",
 760         1204 => "Duration",
 761         1205 => "Number-Copies",
 762         1206 => "Musical Theme",
 763         1207 => "Instruments - total number",
 764         1208 => "Instruments - distinct number",
 765         1209 => "Identifier - URN",
 766         1210 => "Sears Subject Heading",
 767         1211 => "OCLC Number",
 768         1212 => "Composition",
 769         1213 => "Intellectual level",
 770         1214 => "EAN",
 771         1215 => "NLC",
 772         1216 => "CRCS",
 773         1217 => "Nationality",
 774         1218 => "Equinox",
 775         1219 => "Compression",
 776         1220 => "Format",
 777         1221 => "Subject - occupation",
 778         1222 => "Subject - function",
 779         1223 => "Edition",
 780 );
 781
 782 sub bib1_access_point {
 783     my($ap) = @_;
 784
 785     return $_bib1_access_point{$ap} ||
 786         "unknown BIB-1 attribute '$ap'";
 787 }
 788
 789
 790 sub render_record {
 791     my($rs, $which, $elementSetName) = @_;
 792
 793     # There is a slight race condition here on the element-set name,
 794     # but it shouldn't be a problem as this is (currently) only called
 795     # from parts of the program that run single-threaded.
 796     my $old = $rs->option(elementSetName => $elementSetName);
 797     my $rec = $rs->record($which);
 798     $rs->option(elementSetName => $old);
 799
 800     return $rec->render();
 801 }
 802
 803
 804 sub calc_reliability_string {
 805     my($xc) = @_;
 806
 807     my($nok, $nall, $percent) = calc_reliability_stats($xc);
 808     return "[untested]" if $nall == 0;
 809     return "$nok/$nall = " . $percent . "%";
 810 }
 811
 812
 813 sub calc_reliability_stats {
 814     my($xc) = @_;
 815
 816     my $sixtyDaysAgo = time() - 60*24*60*60;
 817     my $iso60DA = isodate($sixtyDaysAgo);
 818     my @allpings = $xc->findnodes("i:status/i:probe");
 819
 820     my($nall, $nok) = (0, 0);
 821     foreach my $node (@allpings) {
 822         my $ok = $xc->findvalue('@ok', $node);
 823         my $when = $node->to_literal();
 824         #warn "$when cmp $iso60DA == ", ($when cmp $iso60DA), "\n";
 825         next if $when lt $iso60DA;
 826         $nall++;
 827         $nok += !!$ok;
 828     }
 829
 830     return (0, 0, 0) if $nall == 0;
 831     my $percent = int(100*$nok/$nall + 0.5);
 832     return ($nok, $nall, $percent);
 833 }
 834
 835 #
 836 # validate_record( record, ( "port" => 1, "database" => 1, "country" => 0, ... ))
 837 #
 838 sub validate_record {
 839     my $rec = shift;
 840     my %args = @_;
 841
 842     my %required = map { $_ => 1 } qw/port host database protocol/;
 843     my %optional = map { $_ => 1 } qw/country type hosturl contact language/;
 844     my %tests = ( %required, %args );
 845
 846     my $xc = irspy_xpath_context($rec);
 847
 848     my $protocol = $xc->findnodes("e:serverInfo/\@protocol") || "";
 849     my $port = $xc->findnodes("e:serverInfo/e:port") || "";
 850     my $host = $xc->findnodes("e:serverInfo/e:host") || "";
 851     my $dbname = $xc->findnodes("e:serverInfo/e:database") || "";
 852
 853     my $id = irspy_make_identifier($protocol, $host, $port, $dbname);
 854
 855     if ($protocol =~ /\s+$/ || $dbname =~ /\s+$/) {
 856         warn "xxx: $protocol:$host:$port:$dbname: whitespaces\n";
 857     }
 858
 859     my @errors = $id;
 860
 861     if ($tests{'protocol'}) {
 862         push(@errors, 'protocol number is not valid') if $protocol !~ /^(z39\.50|sru|srw|tcp)$/i;
 863     }
 864
 865     if ($tests{'port'}) {
 866         push(@errors, 'port number is not valid') if $port !~ /^\d+$/;
 867     }
 868
 869     if ($tests{'host'}) {
 870         push(@errors, 'host name is not valid') if $host !~ /^[0-9a-z]+[0-9a-z\.\-]*\.[0-9a-z]+$/i;
 871     }
 872
 873     if ($tests{'database'}) {
 874         push(@errors, 'database name is not valid') if $dbname =~ m,/,i;
 875         push(@errors, 'database has trailing spaces') if $dbname =~ /^\s+|\s+$/;
 876     }
 877
 878     if ($tests{'hosturl'}) {
 879         my $hosturl = $xc->findnodes("i:status/i:hostURL") || "";
 880         push(@errors, 'This hosturl name is not valid') if $hosturl !~ /^\w+$/i;
 881     }
 882
 883     return ( !$#errors, \@errors );
 884 }
 885
 886 1;