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