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