lib/ZOOM/IRSpy/Utils.pm

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