X-Git-Url: http://git.indexdata.com/?p=irspy-moved-to-github.git;a=blobdiff_plain;f=lib%2FZOOM%2FIRSpy.pm;h=93b519291e87f982667fa3ff74734bfccd556128;hp=d330113440c812a5f1c9f829645a444a7d907b47;hb=ded663f1c0b5c997b1b215320c4290761fdaa520;hpb=a33c7926fe1b1ad19b5d5f3b9e05183ee46315b5 diff --git a/lib/ZOOM/IRSpy.pm b/lib/ZOOM/IRSpy.pm index d330113..93b5192 100644 --- a/lib/ZOOM/IRSpy.pm +++ b/lib/ZOOM/IRSpy.pm @@ -1,4 +1,3 @@ -# $Id: IRSpy.pm,v 1.90 2008-07-16 11:42:13 mike Exp $ package ZOOM::IRSpy; @@ -18,11 +17,15 @@ use ZOOM::IRSpy::Connection; use ZOOM::IRSpy::Stats; use ZOOM::IRSpy::Utils qw(cql_target render_record irspy_xpath_context irspy_make_identifier - irspy_record2identifier); + irspy_record2identifier calc_reliability_stats + modify_xml_document); our @ISA = qw(); -our $VERSION = '1.01'; +our $VERSION = '1.02'; our $irspy_to_zeerex_xsl = dirname(__FILE__) . '/../../xsl/irspy2zeerex.xsl'; +our $debug = 0; +our $xslt_max_depth = 250; +our $max_timeout_errors = 3; # Enumeration for callback functions to return @@ -62,12 +65,14 @@ BEGIN { ZOOM::Log::mask_str("irspy_unhandled"); ZOOM::Log::mask_str("irspy_test"); ZOOM::Log::mask_str("irspy_task"); + ZOOM::Log::mask_str("irspy_data"); } sub new { my $class = shift(); my($dbname, $user, $password, $activeSetSize) = @_; + my @options; push @options, (user => $user, password => $password) if defined $user; @@ -77,10 +82,15 @@ sub new { my $xslt = new XML::LibXSLT; + # raise the maximum number of nested template calls and variables/params (default 250) + warn "raise the maximum number of nested template calls: $xslt_max_depth\n" if $debug; + $xslt->max_depth($xslt_max_depth); + $xslt->register_function($ZOOM::IRSpy::Utils::IRSPY_NS, 'strcmp', \&ZOOM::IRSpy::Utils::xslt_strcmp); my $libxml = new XML::LibXML; + warn "use irspy_to_zeerex_xsl xslt sheet: $irspy_to_zeerex_xsl\n" if $debug; my $xsl_doc = $libxml->parse_file($irspy_to_zeerex_xsl); my $irspy_to_zeerex_style = $xslt->parse_stylesheet($xsl_doc); @@ -101,12 +111,43 @@ sub new { timeout => undef, # Filled in by initialise() tests => undef, # Tree of tests to be executed activeSetSize => defined $activeSetSize ? $activeSetSize : 10, + rules => [], # Can be filled by apply_rules() + vars => {}, # Will contain name, id, version, etc. + # May be written into by tests (mostly + # Ping, which gets the Init response) + # and read by tests for rules. }, $class; $this->log("irspy", "starting up with database '$dbname'"); return $this; } +# Read from and write to the set of vars +sub var { + my $this = shift(); + my($key, $newval) = @_; + + if (defined $newval) { + $this->{vars}->{$key} = $newval; + #warn "$this: set '$key'='$newval'"; + } else { + my $oldval = $this->{vars}->{$key}; + $oldval = "" if !defined $oldval; + #warn "$this: got '$key'='$oldval'"; + return $oldval; + } +} + +# wrapper to read the IRSpy database name from environment variable / apache config +sub connect_to_registry { + my %args = @_; + + # XXX: we could also handle her: user, password, elementSetName + + my $database = $ENV{IRSpyDbName} || "localhost:8018/IR-Explain---1"; + + return $database; +} sub log { my $this = shift(); @@ -175,6 +216,26 @@ sub restrict_modulo { } +sub apply_rules { + my $this = shift(); + my($fileName) = @_; + + my $f = new IO::File("<$fileName") + or die "$0: can't open rules file '$fileName': $!"; + + while (my $line = <$f>) { + chomp $line; + $line =~ s/#.*//; + $line =~ s/\s+$//; + next if !$line; + my(@fields) = split /\s+/, $line; + my($name, $op, $val, $rule, @params) = @fields; + #warn "parsed name='$name', op='$op', val='$val', rule='$rule', params='@params'\n"; + push @{ $this->{rules} }, [ @fields ]; + } + $f->close(); +} + # Records must be fetched for all records satisfying $this->{query} If # $this->{targets} is already set (i.e. a specific list of targets to # check was specified by a call to targets()), then new, empty records @@ -305,9 +366,20 @@ sub _rewrite_irspy_record { } +my $_reliabilityField = { + reliability => [ reliability => 0, + "Calculated reliability of server", + "e:serverInfo/e:reliability" ], +}; + sub _rewrite_zeerex_record { my($conn, $rec, $oldid) = @_; + # Add reliability score + my $xc = irspy_xpath_context($rec); + my($nok, $nall, $percent) = calc_reliability_stats($xc); + modify_xml_document($xc, $_reliabilityField, { reliability => $percent }); + my $p = $conn->package(); $p->option(action => "specialUpdate"); my $xml = $rec->toString(); @@ -317,7 +389,6 @@ sub _rewrite_zeerex_record { # This is the expression in the ID-making stylesheet # ../../zebra/zeerex2id.xsl - my $xc = irspy_xpath_context($rec); my $id = irspy_record2identifier($xc); if (defined $oldid && $id ne $oldid) { warn "IDs differ (old='$oldid' new='$id')"; @@ -414,10 +485,12 @@ sub check { while (1) { my @copy_conn = @conn; # avoid alias problems after splice() my $nconn = scalar(@copy_conn); + foreach my $i0 (0 .. $#copy_conn) { my $conn = $copy_conn[$i0]; #print "connection $i0 of $nconn/", scalar(@conn), " is $conn\n"; next if !defined $conn; + if (!$conn->current_task()) { if (!$conn->next_task()) { # Out of tasks: we need a new test @@ -431,6 +504,12 @@ sub check { "checking for next test after '$address'"); $nextaddr = $this->_next_test($address); } + + if (ZOOM::IRSpy::Test::zoom_error_timeout_check($conn)) { + $conn->log("irspy", "Got to many timeouts, stop testing"); + undef $nextaddr; + } + if (!defined $nextaddr) { $conn->log("irspy", "has no more tests: removing"); $this->_rewrite_irspy_record($conn); @@ -454,6 +533,13 @@ sub check { or die "invalid nextaddr '$nextaddr'"; $conn->option(current_test_address => $nextaddr); my $tname = $node->name(); + if ($this->should_skip_test($tname)) { + $conn->log("irspy_test", + "skipping test '$nextaddr' = $tname due to rule"); + $nskipped += 1; + goto NEXT_TEST; + } + $conn->log("irspy_test", "starting test '$nextaddr' = $tname"); my $tasks = $conn->tasks(); @@ -472,6 +558,13 @@ sub check { my $task = $conn->next_task(); die "no next task queued for $conn" if !defined $task; + + # do not run the next task if we got too many timeouts + if (ZOOM::IRSpy::Test::zoom_error_timeout_check($conn)) { + $conn->log("irspy_task", "Got too many timeouts for this target, do not start a new task"); + next; + } + $conn->log("irspy_task", "preparing task $task"); $conn->next_task(0); $conn->current_task($task); @@ -549,7 +642,7 @@ sub check { my $skipcount = 0; while (defined $node->next() && length($node->next()->address()) >= length($address)) { - $conn->log("irspy_debug", "skipping from '", + $conn->log("irspy_test", "skipping from '", $node->address(), "' to '", $node->next()->address(), "'"); $node = $node->next(); @@ -636,6 +729,30 @@ sub check { } +### This could of course call a much more general looping evaluator +sub should_skip_test { + my $this = shift(); + my($tname) = @_; + + foreach my $rule (@{ $this->{rules} }) { + my($name, $op, $val, $rule, @params) = @$rule; + #warn "using name='$name', op='$op', val='$val', rule='$rule', params='@params'\n"; + if ($op eq "~" && + $rule eq "skip" && + $params[0] eq $tname) { + my $re = $val; + $re =~ s/^\/(.*)\/$/$1/; + if ($this->var($name) =~ $re) { + #warn "$name '", $this->var($name), "' matches /$re/ -- skipping '$tname'"; + return 1; + } + } + } + + return 0; +} + + # Exactly equivalent to ZOOM::event() except that it is tolerant to # undefined values in the array being passed in. # @@ -706,7 +823,10 @@ sub _next_test { return undef if $address eq ""; # Try next sibling child - my @components = split /:/, $address; + # The use of a regexp in split() is to avoid confusing Emacs's + # Perl mode; the third colon is to avoid looking like a POSIX + # named character class ... *sigh* + my @components = split /[:::]/, $address; my $last = pop @components; my $maybe = join(":", @components, $last+1); return $maybe if $this->{tree}->select($maybe); @@ -717,6 +837,7 @@ sub _next_test { sub _last_sibling_test { + die "_last_sibling_test() called -- I thought that never happened?"; my $this = shift(); my($address) = @_; @@ -737,10 +858,11 @@ sub _last_sibling_test { sub _next_sibling_test { + die "_next_sibling_test() called -- I thought that never happened?"; my $this = shift(); my($address) = @_; - my @components = split /:/, $address; + my @components = split /[:::]/, $address; my $last = pop @components; my $maybe = join(":", @components, $last+1); return $maybe if $this->{tree}->select($maybe);