2 package ZOOM::IRSpy::Utils;
10 use Exporter 'import';
11 our @EXPORT_OK = qw(utf8param
20 irspy_record2identifier
21 irspy_identifier2target
26 calc_reliability_string
27 calc_reliability_stats);
30 use XML::LibXML::XPathContext;
32 use Encode qw(is_utf8);
35 our $IRSPY_NS = 'http://indexdata.com/irspy/1.0';
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.
46 my %_paramsbyrequest; # Used for Apache2 only
48 my($r, $key, $value) = @_;
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};
56 require Apache2::Request;
57 #warn "making new Apache2::RequestReq for '$r'";
58 $r = $_apache2request{$r} = new Apache2::Request($r);
63 return map { decode_utf8($_) } $r->param();
67 $raw = $_paramsbyrequest{$r}->{$key} if $r->isa('Apache2::Request');
68 $raw = $r->param($key) if !defined $raw;
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);
78 $r->param($key, encode_utf8($value));
82 return undef if !defined $raw;
83 my $cooked = decode_utf8($raw);
84 warn "converted '$raw' to '", $cooked, "'\n" if $cooked ne $raw;
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;
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;
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);
109 # strips whitespaces at start and ends of a field
119 # utf8param() with trim
121 my $result = utf8param(@_);
123 if (defined $result) {
124 $result = trimField($result);
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!
136 my($text, $fallback, $opts) = @_;
137 if (!defined $opts && ref $fallback) {
138 # The second and third arguments are both optional
142 $opts = {} if !defined $opts;
144 $text = $fallback if !defined $text;
146 confess "xml_encode(): text and fallback both undefined"
149 $text =~ s/&/&/g;
152 # Internet Explorer can't display ' (!) so don't create it
153 #$text =~ s/['']/'/g;
154 $text =~ s/[""]/"/g;
155 $text =~ s/ / /g if $opts->{nbsp};
161 # Quotes a term for use in a CQL query
165 $term =~ s/([""\\*?])/\\$1/g;
166 $term = qq["$term"] if $term =~ /[\s""\/]/;
171 # Makes a CQL query that finds a specified target. Arguments may be
172 # either an ID alone, or a (host, port, db) triple.
174 my($protocol, $host, $port, $db) = @_;
178 $id = irspy_make_identifier($protocol, $host, $port, $db);
183 return "rec.id=" . cql_quote($id);
184 #return "rec.id_raw=" . cql_quote($id);
188 # PRIVATE to irspy_namespace() and irspy_xpath_context()
190 e => 'http://explain.z3950.org/dtd/2.0/',
195 sub irspy_namespace {
199 confess "irspy_namespace(undef)" if !defined $prefix;
200 my $uri = $_namespaces{$prefix};
201 die "irspy_namespace(): no URI for namespace prefix '$prefix'"
208 sub irspy_xpath_context {
211 if (ref $record && $record->isa("ZOOM::Record")) {
212 $record = $record->render();
219 my $parser = new XML::LibXML();
220 my $doc = $parser->parse_string($record);
221 $root = $doc->getDocumentElement();
224 my $xc = XML::LibXML::XPathContext->new($root);
225 foreach my $prefix (keys %_namespaces) {
226 $xc->registerNs($prefix, $_namespaces{$prefix});
232 # Construct an opaque identifier from its components. Although it's
233 # trivial, this is needed in so many places that it really needs to be
236 # This is the converse of _parse_target_string() in IRSpy.pm, which
237 # should be renamed and moved into this package.
239 sub irspy_make_identifier {
240 my($protocol, $host, $port, $dbname) = @_;
242 die "irspy_make_identifier(" . join(", ", map { "'$_'" } @_).
243 "): wrong number of arguments" if @_ != 4;
245 die "irspy_make_identifier(): protocol undefined" if !defined $protocol;
246 die "irspy_make_identifier(): host undefined" if !defined $host;
247 die "irspy_make_identifier(): port undefined" if !defined $port;
248 die "irspy_make_identifier(): dbname undefined" if !defined $dbname;
250 return "$protocol:$host:$port/$dbname";
254 # Returns the opaque identifier of an IRSpy record based on the
255 # XPathContext'ed DOM object, as returned by irspy_xpath_context().
256 # This is doing the same thing as irspy_make_identifier() but from a
257 # record rather than a set of parameters.
259 sub irspy_record2identifier {
262 ### Must be kept the same as is used in ../../../zebra/*.xsl
263 return $xc->find("concat(e:serverInfo/\@protocol, ':',
264 e:serverInfo/e:host, ':',
265 e:serverInfo/e:port, '/',
266 e:serverInfo/e:database)");
270 # Transforms an IRSpy opqaue identifier, as returned from
271 # irspy_make_identifier() or irspy_record2identifier(), into a YAZ
272 # target-string suitable for feeding to ZOOM. Before we introduced
273 # the protocol element at the start of the identifier string, this was
274 # a null transform; now we have to be a bit cleverer.
276 sub irspy_identifier2target {
277 my $res = _irspy_identifier2target(@_);
278 #carp "converted ID '@_' to target '$res'";
282 sub _irspy_identifier2target {
285 confess "_irspy_identifier2target(): id is undefined"
288 my($prefix, $protocol, $target) = ($id =~ /([^:]*,)?(.*?):(.*)/);
290 if (uc($protocol) eq "Z39.50" || uc($protocol) eq "TCP") {
291 return "${prefix}tcp:$target";
292 } elsif (uc($protocol) eq "SRU") {
293 return "${prefix}sru=get,http:$target";
294 } elsif (uc($protocol) eq "SRW") {
295 return "${prefix}sru=srw,http:$target";
298 warn "_irspy_identifier2target($id): unrecognised protocol '$protocol'";
303 # Modifies the XML document for which $xc is an XPath context by
304 # inserting or replacing the values specified in the hash %$data. The
305 # keys are fieldnames, which are looked up in the register
306 # $fieldsByKey to determine, among other things, what their XPath is.
308 sub modify_xml_document {
309 my($xc, $fieldsByKey, $data) = @_;
312 foreach my $key (keys %$data) {
313 my $value = $data->{$key};
314 my $ref = $fieldsByKey->{$key} or die "no field '$key'";
315 my($name, $nlines, $caption, $xpath, @addAfter) = @$ref;
316 #print "Considering $key='$value' ($xpath)<br/>\n";
317 my @nodes = $xc->findnodes($xpath);
319 warn scalar(@nodes), " nodes match '$xpath'" if @nodes > 1;
320 my $node = $nodes[0];
322 if ($node->isa("XML::LibXML::Attr")) {
323 if ($value ne $node->getValue()) {
324 $node->setValue($value);
326 #print "Attr $key: '", $node->getValue(), "' -> '$value' ($xpath)<br/>\n";
328 } elsif ($node->isa("XML::LibXML::Element")) {
329 # The contents could be any mixture of text and
330 # comments and maybe even other crud such as processing
331 # instructions. The simplest thing is just to throw it all
332 # away and start again, making a single Text node the
333 # canonical representation. But before we do that,
334 # we'll check whether the element is already
335 # canonical, to determine whether our change is a
338 my @children = $node->childNodes();
339 if (@children == 1) {
340 my $child = $node->firstChild();
341 if (ref $child && ref $child eq "XML::LibXML::Text") {
342 $old = $child->getData();
343 #print STDERR "child='$child', old=", _renderchars($old), "\n" if $key eq "title";
346 next if $value eq $old;
348 $node->removeChildNodes();
349 my $child = new XML::LibXML::Text($value);
350 $node->appendChild($child);
352 #print STDERR "Elem $key ($xpath): ", _renderchars($old), " -> '", _renderchars($value), "\n";
354 warn "unexpected node type $node";
358 next if !defined $value; # No need to create a new empty node
359 my($ppath, $selector) = $xpath =~ /(.*)\/(.*)/;
360 dom_add_node($xc, $ppath, $selector, $value, @addAfter);
361 #print "New $key ($xpath) = '$value'<br/>\n";
373 return "'" . $text . "'", " (", join(" ", map {ord($_)} split //, $text), "), is_utf8=" , is_utf8($text);
378 my($xc, $ppath, $selector, $value, @addAfter) = @_;
380 #print "Adding $selector='$value' at '$ppath' after (", join(", ", map { "'$_'" } @addAfter), ")<br/>\n";
381 my $node = find_or_make_node($xc, $ppath, 0);
382 die "couldn't find or make node '$node'" if !defined $node;
384 my $is_attr = ($selector =~ s/^@//);
385 my(undef, $prefix, $simpleSel) = $selector =~ /((.*?):)?(.*)/;
386 #warn "selector='$selector', prefix='$prefix', simpleSel='$simpleSel'";
388 if (defined $prefix) {
389 ### This seems to no-op (thank, DOM!) but I have have no
390 # idea, and it's not needed for IRSpy, so I am not going
392 $node->setAttributeNS(irspy_namespace($prefix),
395 $node->setAttribute($simpleSel, $value);
400 my $new = new XML::LibXML::Element($simpleSel);
401 $new->setNamespace(irspy_namespace($prefix), $prefix)
404 $new->appendText($value);
405 foreach my $predecessor (reverse @addAfter) {
406 my($child) = $xc->findnodes($predecessor, $node);
407 if (defined $child) {
408 $node->insertAfter($new, $child);
409 #warn "Added after '$predecessor'";
414 # Didn't find any of the nodes that are supposed to precede the
415 # new one, so we need to insert the new node as the first of the
416 # parent's children. However *sigh* there is no prependChild()
417 # analogous to appendChild(), so we have to go the long way round.
418 my @children = $node->childNodes();
420 $node->insertBefore($new, $children[0]);
421 #warn "Added new first child";
423 $node->appendChild($new);
424 #warn "Added new only child";
428 my $text = xml_encode(inheritance_tree($xc));
429 $text =~ s/\n/<br\/>$&/sg;
430 print "<pre>$text</pre>\n";
435 sub find_or_make_node {
436 my($xc, $path, $recursion_level) = @_;
438 die "deep recursion in find_or_make_node($path)"
439 if $recursion_level == 10;
440 $path = "." if $path eq "";
442 my @nodes = $xc->findnodes($path);
444 # Oh dear, the parent node doesn't exist. We could make it,
445 my(undef, $ppath, $element) = $path =~ /((.*)\/)?(.*)/;
446 $ppath = "" if !defined $ppath;
447 #warn "path='$path', ppath='$ppath', element='$element'";
448 #warn "no node '$path': making it";
449 my $parent = find_or_make_node($xc, $ppath, $recursion_level-1);
451 my(undef, $prefix, $nsElem) = $element =~ /((.*?):)?(.*)/;
452 #warn "element='$element', prefix='$prefix', nsElem='$nsElem'";
453 my $new = new XML::LibXML::Element($nsElem);
454 if (defined $prefix) {
455 #warn "setNamespace($prefix)";
456 $new->setNamespace(irspy_namespace($prefix), $prefix);
459 $parent->appendChild($new);
462 warn scalar(@nodes), " nodes match parent '$path'" if @nodes > 1;
467 sub inheritance_tree {
468 my($type, $level) = @_;
469 $level = 0 if !defined $level;
470 return "Woah! Too deep, man!\n" if $level > 20;
472 $type = ref $type if ref $type;
474 $text = "--> " if $level == 0;
475 $text .= ("\t" x $level) . "$type\n";
476 my @ISA = eval "\@${type}::ISA";
477 foreach my $superclass (@ISA) {
478 $text .= inheritance_tree($superclass, $level+1);
485 # This function is made available in xslt using the register_function call
487 my ($arg1, $arg2) = @_;
488 return "$arg1" cmp "$arg2";
492 ### It feels like this should be in YAZ, exported via ZOOM-Perl.
493 my %_bib1_access_point = (
494 1 => "Personal name",
495 2 => "Corporate name",
496 3 => "Conference name",
499 6 => "Title uniform",
502 9 => "LC card number",
503 10 => "BNB card no.",
505 12 => "Local number",
506 13 => "Dewey classification",
507 14 => "UDC classification",
508 15 => "Bliss classification",
509 16 => "LC call number",
510 17 => "NLM call number",
511 18 => "NAL call number",
512 19 => "MOS call number",
513 20 => "Local classification",
514 21 => "Subject heading",
515 22 => "Subject Rameau",
516 23 => "BDI index subject",
517 24 => "INSPEC subject",
518 25 => "MESH subject",
520 27 => "LC subject heading",
521 28 => "RVM subject heading",
522 29 => "Local subject index",
524 31 => "Date of publication",
525 32 => "Date of acquisition",
527 34 => "Title collective",
528 35 => "Title parallel",
530 37 => "Title added title page",
531 38 => "Title caption",
532 39 => "Title running",
534 41 => "Title other variant",
535 42 => "Title former",
536 43 => "Title abbreviated",
537 44 => "Title expanded",
538 45 => "Subject precis",
539 46 => "Subject rswk",
540 47 => "Subject subdivision",
541 48 => "No. nat'l biblio.",
542 49 => "No. legal deposit",
543 50 => "No. govt pub.",
544 51 => "No. music publisher",
546 53 => "Number local call",
547 54 => "Code--language",
548 55 => "Code--geographic area",
549 56 => "Code--institution",
550 57 => "Name and title *",
551 58 => "Name geographic",
552 59 => "Place publication",
554 61 => "Microform generation",
557 1000 => "Author-title",
558 1001 => "Record type",
561 1004 => "Author-name personal",
562 1005 => "Author-name corporate",
563 1006 => "Author-name conference",
564 1007 => "Identifier--standard",
565 1008 => "Subject--LC children's",
566 1009 => "Subject name -- personal",
567 1010 => "Body of text",
568 1011 => "Date/time added to db",
569 1012 => "Date/time last modified",
570 1013 => "Authority/format id",
571 1014 => "Concept-text",
572 1015 => "Concept-reference",
574 1017 => "Server-choice",
576 1019 => "Record-source",
579 1022 => "Geographic-class",
580 1023 => "Indexed-by",
583 1026 => "Related-periodical",
584 1027 => "Report-number",
585 1028 => "Stock-number",
586 1030 => "Thematic-number",
587 1031 => "Material-type",
590 1034 => "Content-type",
592 1036 => "Author-Title-Subject",
593 1032 => "Doc-id (semantic definition change)",
595 1038 => "Abstract-language",
596 1039 => "Application-kind",
597 1040 => "Classification",
598 1041 => "Classification-basic",
599 1042 => "Classification-local-record",
601 1044 => "Possessing-institution",
602 1045 => "Record-linking",
603 1046 => "Record-status",
605 1048 => "Control-number-GKD",
606 1049 => "Control-number-linking",
607 1050 => "Control-number-PND",
608 1051 => "Control-number-SWD",
609 1052 => "Control-number-ZDB",
610 1053 => "Country-publication (country of Publication)",
611 1054 => "Date-conference (meeting date)",
612 1055 => "Date-record-status",
613 1056 => "Dissertation-information",
614 1057 => "Meeting-organizer",
615 1058 => "Note-availability",
616 1059 => "Number-CAS-registry (CAS registry number)",
617 1060 => "Number-document (document number)",
618 1061 => "Number-local-accounting",
619 1062 => "Number-local-acquisition",
620 1063 => "Number-local-call-copy-specific",
621 1064 => "Number-of-reference (reference count)",
622 1065 => "Number-norm",
623 1066 => "Number-volume",
624 1067 => "Place-conference (meeting location)",
625 1068 => "Reference (references and footnotes)",
626 1069 => "Referenced-journal (reference work)",
627 1070 => "Section-code",
628 1071 => "Section-heading",
629 1072 => "Subject-GOO",
630 1073 => "Subject-name-conference",
631 1074 => "Subject-name-corporate",
632 1075 => "Subject-genre/form",
633 1076 => "Subject-name-geographical",
634 1077 => "Subject--chronological",
635 1078 => "Subject--title",
636 1079 => "Subject--topical",
637 1080 => "Subject-uncontrolled",
638 1081 => "Terminology-chemical (chemical name)",
639 1082 => "Title-translated",
640 1083 => "Year-of-beginning",
641 1084 => "Year-of-ending",
642 1085 => "Subject-AGROVOC",
643 1086 => "Subject-COMPASS",
644 1087 => "Subject-EPT",
645 1088 => "Subject-NAL",
646 1089 => "Classification-BCM",
647 1090 => "Classification-DB",
648 1091 => "Identifier-ISRC",
649 1092 => "Identifier-ISMN",
650 1093 => "Identifier-ISRN",
651 1094 => "Identifier-DOI",
652 1095 => "Code-language-original",
653 1096 => "Title-later",
655 1098 => "DC-Creator",
656 1099 => "DC-Subject",
657 1100 => "DC-Description",
658 1101 => "DC-Publisher",
660 1103 => "DC-ResourceType",
661 1104 => "DC-ResourceIdentifier",
662 1105 => "DC-Language",
663 1106 => "DC-OtherContributor",
666 1109 => "DC-Relation",
667 1110 => "DC-Coverage",
668 1111 => "DC-RightsManagement",
669 1112 => "Controlled Subject Index",
670 1113 => "Subject Thesaurus",
671 1114 => "Index Terms -- Controlled",
672 1115 => "Controlled Term",
673 1116 => "Spatial Domain",
674 1117 => "Bounding Coordinates",
675 1118 => "West Bounding Coordinate",
676 1119 => "East Bounding Coordinate",
677 1120 => "North Bounding Coordinate",
678 1121 => "South Bounding Coordinate",
680 1123 => "Place Keyword Thesaurus",
681 1124 => "Place Keyword",
682 1125 => "Time Period",
683 1126 => "Time Period Textual",
684 1127 => "Time Period Structured",
685 1128 => "Beginning Date",
686 1129 => "Ending Date",
687 1130 => "Availability",
688 1131 => "Distributor",
689 1132 => "Distributor Name",
690 1133 => "Distributor Organization",
691 1134 => "Distributor Street Address",
692 1135 => "Distributor City",
693 1136 => "Distributor State or Province",
694 1137 => "Distributor Zip or Postal Code",
695 1138 => "Distributor Country",
696 1139 => "Distributor Network Address",
697 1140 => "Distributor Hours of Service",
698 1141 => "Distributor Telephone",
699 1142 => "Distributor Fax",
700 1143 => "Resource Description",
701 1144 => "Order Process",
702 1145 => "Order Information",
704 1147 => "Cost Information",
705 1148 => "Technical Prerequisites",
706 1149 => "Available Time Period",
707 1150 => "Available Time Textual",
708 1151 => "Available Time Structured",
709 1152 => "Available Linkage",
710 1153 => "Linkage Type",
712 1155 => "Sources of Data",
713 1156 => "Methodology",
714 1157 => "Access Constraints",
715 1158 => "General Access Constraints",
716 1159 => "Originator Dissemination Control",
717 1160 => "Security Classification Control",
718 1161 => "Use Constraints",
719 1162 => "Point of Contact",
720 1163 => "Contact Name",
721 1164 => "Contact Organization",
722 1165 => "Contact Street Address",
723 1166 => "Contact City",
724 1167 => "Contact State or Province",
725 1168 => "Contact Zip or Postal Code",
726 1169 => "Contact Country",
727 1170 => "Contact Network Address",
728 1171 => "Contact Hours of Service",
729 1172 => "Contact Telephone",
730 1173 => "Contact Fax",
731 1174 => "Supplemental Information",
733 1176 => "Agency Program",
734 1177 => "Cross Reference",
735 1178 => "Cross Reference Title",
736 1179 => "Cross Reference Relationship",
737 1180 => "Cross Reference Linkage",
738 1181 => "Schedule Number",
739 1182 => "Original Control Identifier",
740 1183 => "Language of Record",
741 1184 => "Record Review Date",
743 1186 => "Performer-Individual",
744 1187 => "Performer-Group",
745 1188 => "Instrumentation",
746 1189 => "Instrumentation-Original",
747 1190 => "Instrumentation-Current",
748 1191 => "Arrangement",
749 1192 => "Arrangement-Original",
750 1193 => "Arrangement-Current",
751 1194 => "Musical Key-Original",
752 1195 => "Musical Key-Current",
753 1196 => "Date-Composition",
754 1197 => "Date-Recording",
755 1198 => "Place-Recording",
756 1199 => "Country-Recording",
757 1200 => "Number-ISWC",
758 1201 => "Number-Matrix",
759 1202 => "Number-Plate",
760 1203 => "Classification-McColvin",
762 1205 => "Number-Copies",
763 1206 => "Musical Theme",
764 1207 => "Instruments - total number",
765 1208 => "Instruments - distinct number",
766 1209 => "Identifier - URN",
767 1210 => "Sears Subject Heading",
768 1211 => "OCLC Number",
769 1212 => "Composition",
770 1213 => "Intellectual level",
774 1217 => "Nationality",
776 1219 => "Compression",
778 1221 => "Subject - occupation",
779 1222 => "Subject - function",
783 sub bib1_access_point {
786 return $_bib1_access_point{$ap} ||
787 "unknown BIB-1 attribute '$ap'";
792 my($rs, $which, $elementSetName) = @_;
794 # There is a slight race condition here on the element-set name,
795 # but it shouldn't be a problem as this is (currently) only called
796 # from parts of the program that run single-threaded.
797 my $old = $rs->option(elementSetName => $elementSetName);
798 my $rec = $rs->record($which);
799 $rs->option(elementSetName => $old);
801 return $rec->render();
805 sub calc_reliability_string {
808 my($nok, $nall, $percent) = calc_reliability_stats($xc);
809 return "[untested]" if $nall == 0;
810 return "$nok/$nall = " . $percent . "%";
814 sub calc_reliability_stats {
817 my $sixtyDaysAgo = time() - 60*24*60*60;
818 my $iso60DA = isodate($sixtyDaysAgo);
819 my @allpings = $xc->findnodes("i:status/i:probe");
821 my($nall, $nok) = (0, 0);
822 foreach my $node (@allpings) {
823 my $ok = $xc->findvalue('@ok', $node);
824 my $when = $node->to_literal();
825 #warn "$when cmp $iso60DA == ", ($when cmp $iso60DA), "\n";
826 next if $when lt $iso60DA;
831 return (0, 0, 0) if $nall == 0;
832 my $percent = int(100*$nok/$nall + 0.5);
833 return ($nok, $nall, $percent);
837 # validate_record( record, ( "port" => 1, "database" => 1, "country" => 0, ... ))
839 sub validate_record {
843 my %required = map { $_ => 1 } qw/port host database protocol/;
844 my %optional = map { $_ => 1 } qw/country type hosturl contact language/;
845 my %tests = ( %required, %args );
847 my $xc = irspy_xpath_context($rec);
849 my $protocol = $xc->findnodes("e:serverInfo/\@protocol") || "";
850 my $port = $xc->findnodes("e:serverInfo/e:port") || "";
851 my $host = $xc->findnodes("e:serverInfo/e:host") || "";
852 my $dbname = $xc->findnodes("e:serverInfo/e:database") || "";
854 my $id = irspy_make_identifier($protocol, $host, $port, $dbname);
856 if ($protocol =~ /\s+$/ || $dbname =~ /\s+$/) {
857 warn "xxx: $protocol:$host:$port:$dbname: whitespaces\n";
862 if ($tests{'protocol'}) {
863 push(@errors, 'protocol number is not valid') if $protocol !~ /^(z39\.50|sru|srw|tcp)$/i;
866 if ($tests{'port'}) {
867 push(@errors, 'port number is not valid') if $port !~ /^\d+$/;
870 if ($tests{'host'}) {
871 push(@errors, 'host name is not valid') if $host !~ /^[0-9a-z]+[0-9a-z\.\-]*\.[0-9a-z]+$/i;
874 if ($tests{'database'}) {
875 push(@errors, 'database name is not valid') if $dbname =~ m,/,i;
876 push(@errors, 'database has trailing spaces') if $dbname =~ /^\s+|\s+$/;
879 if ($tests{'hosturl'}) {
880 my $hosturl = $xc->findnodes("i:status/i:hostURL") || "";
881 push(@errors, 'This hosturl name is not valid') if $hosturl !~ /^\w+$/i;
884 return ( !$#errors, \@errors );