From a71cc3bc7959020502c5a2ba0fe907cd7afaab6c Mon Sep 17 00:00:00 2001 From: Mike Taylor Date: Mon, 6 Sep 2010 17:42:44 +0100 Subject: [PATCH] Support for rules files, and specifically for the "skip" rule: IRSpy object now has an array of 0 or more rules. New method apply_rules() to parse rules for later application [misnamed]. IRSpy object now has a set of name=>value variables. New method var() for setting and getting variables. New method should_skip_test() consults rules for a named test. Skip a named test if a rule says to do so. Some fiddling with split() calls to avoid confusing Emacs's Perl mode. Add die() calls to the methods _last_sibling_test() and _next_sibling_test() which seem never to be called. Assuming they don't start firing, I will remove these methods soon. --- lib/ZOOM/IRSpy.pm | 81 +++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 78 insertions(+), 3 deletions(-) diff --git a/lib/ZOOM/IRSpy.pm b/lib/ZOOM/IRSpy.pm index 4e2040c..de2c561 100644 --- a/lib/ZOOM/IRSpy.pm +++ b/lib/ZOOM/IRSpy.pm @@ -110,12 +110,33 @@ 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 = @_; @@ -194,6 +215,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 @@ -491,6 +532,11 @@ sub check { or die "invalid nextaddr '$nextaddr'"; $conn->option(current_test_address => $nextaddr); my $tname = $node->name(); + if ($this->should_skip_test($tname)) { + warn "skipping test '$tname' due to rule"; + goto NEXT_TEST; + } + $conn->log("irspy_test", "starting test '$nextaddr' = $tname"); my $tasks = $conn->tasks(); @@ -512,7 +558,7 @@ sub check { # 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 to many timeouts for this target, do not start a new task"); + $conn->log("irspy_task", "Got too many timeouts for this target, do not start a new task"); next; } @@ -680,6 +726,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. # @@ -750,7 +820,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); @@ -761,6 +834,7 @@ sub _next_test { sub _last_sibling_test { + die "_last_sibling_test() called -- I thought that never happened?"; my $this = shift(); my($address) = @_; @@ -781,10 +855,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); -- 1.7.10.4