lib/ZOOM/IRSpy/Test/Ping.pm

   1 # $Id: Ping.pm,v 1.23 2007-04-30 11:26:57 mike Exp $
   2
   3 # See the "Main" test package for documentation
   4
   5 package ZOOM::IRSpy::Test::Ping;
   6
   7 use 5.008;
   8 use strict;
   9 use warnings;
  10
  11 use ZOOM::IRSpy::Test;
  12 our @ISA = qw(ZOOM::IRSpy::Test);
  13
  14 use ZOOM::IRSpy::Utils qw(isodate);
  15
  16 use Text::Iconv;
  17 my $conv = new Text::Iconv("LATIN1", "UTF8");
  18
  19
  20 sub start {
  21     my $class = shift();
  22     my($conn) = @_;
  23
  24     $conn->irspy_connect(undef, {},
  25                          ZOOM::Event::ZEND, \&connected,
  26                          exception => \&not_connected);
  27 }
  28
  29
  30 sub connected { maybe_connected(@_, 1) }
  31 sub not_connected { maybe_connected(@_, 0) }
  32
  33 sub maybe_connected {
  34     my($conn, $task, $__UNUSED_udata, $event, $ok) = @_;
  35
  36     $conn->log("irspy_test", ($ok ? "" : "not "), "connected");
  37     my $rec = $conn->record();
  38     $rec->append_entry("irspy:status", "<irspy:probe ok='$ok'>" .
  39                        isodate(time()) . "</irspy:probe>");
  40
  41     if ($ok) {
  42         foreach my $opt (qw(search present delSet resourceReport
  43                             triggerResourceCtrl resourceCtrl
  44                             accessCtrl scan sort extendedServices
  45                             level_1Segmentation level_2Segmentation
  46                             concurrentOperations namedResultSets
  47                             encapsulation resultCount negotiationModel
  48                             duplicationDetection queryType104
  49                             pQESCorrection stringSchema)) {
  50             #print STDERR "\$conn->option('init_opt_$opt') = '", $conn->option("init_opt_$opt"), "'\n";
  51             $conn->record()->store_result('init_opt', option => $opt)
  52                 if $conn->option("init_opt_$opt");
  53         }
  54
  55         foreach my $opt (qw(serverImplementationId
  56                             serverImplementationName
  57                             serverImplementationVersion)) {
  58             my $val = $conn->option($opt);
  59             next if !defined $val; # not defined for SRU, for example
  60
  61             # There doesn't seem to be a reliable way to tell what
  62             # character set the server uses for these.  At least one
  63             # server (z3950.bcl.jcyl.es:210/AbsysCCFL) returns an ISO
  64             # 8859-1 string containing an o-acute, which breaks the
  65             # XML parser if we just insert it naively.  It seems
  66             # reasonable, though, to guess that the great majority of
  67             # servers will use ASCII, Latin-1 or Unicode.  The first
  68             # of these is a subset of the second, so that brings it to
  69             # down to two.  The strategy is simply this: assume it's
  70             # ASCII-Latin-1, and try to convert to UTF-8.  If that
  71             # conversion works, fine; if not, assume it's because the
  72             # string was already UTF-8, so use it as is.
  73             Text::Iconv->raise_error(1);
  74             my $maybe;
  75             eval {
  76                 $maybe = $conv->convert($val);
  77             }; if (!$@ && $maybe ne $val) {
  78                 $conn->log("irspy", "converted '$val' from Latin-1 to UTF-8");
  79                 $val = $maybe;
  80             }
  81             $conn->record()->store_result($opt, value => $val);
  82         }
  83     }
  84
  85
  86     return $ok ? ZOOM::IRSpy::Status::TEST_GOOD :
  87                  ZOOM::IRSpy::Status::TEST_BAD;
  88 }
  89
  90
  91 1;