diff options
| -rw-r--r-- | NPTest.pm | 146 |
1 files changed, 73 insertions, 73 deletions
| @@ -53,8 +53,8 @@ developer to interactively request test parameter information from the | |||
| 53 | user. The user can accept the developer's default value or reply "none" | 53 | user. The user can accept the developer's default value or reply "none" |
| 54 | which will then be returned as "" for the test to skip if appropriate. | 54 | which will then be returned as "" for the test to skip if appropriate. |
| 55 | 55 | ||
| 56 | If a parameter needs to be entered and the test is run without a tty | 56 | If a parameter needs to be entered and the test is run without a tty |
| 57 | attached (such as a cronjob), the parameter will be assigned as if it | 57 | attached (such as a cronjob), the parameter will be assigned as if it |
| 58 | was "none". Tests can check for the parameter and skip if not set. | 58 | was "none". Tests can check for the parameter and skip if not set. |
| 59 | 59 | ||
| 60 | Responses are stored in an external, file-based cache so subsequent test | 60 | Responses are stored in an external, file-based cache so subsequent test |
| @@ -249,26 +249,26 @@ sub checkCmd | |||
| 249 | { | 249 | { |
| 250 | if ( scalar( grep { $_ == $exitStatus } @{$desiredExitStatus} ) ) | 250 | if ( scalar( grep { $_ == $exitStatus } @{$desiredExitStatus} ) ) |
| 251 | { | 251 | { |
| 252 | $desiredExitStatus = $exitStatus; | 252 | $desiredExitStatus = $exitStatus; |
| 253 | } | 253 | } |
| 254 | else | 254 | else |
| 255 | { | 255 | { |
| 256 | $desiredExitStatus = -1; | 256 | $desiredExitStatus = -1; |
| 257 | } | 257 | } |
| 258 | } | 258 | } |
| 259 | elsif ( ref $desiredExitStatus eq "HASH" ) | 259 | elsif ( ref $desiredExitStatus eq "HASH" ) |
| 260 | { | 260 | { |
| 261 | if ( exists( ${$desiredExitStatus}{$exitStatus} ) ) | 261 | if ( exists( ${$desiredExitStatus}{$exitStatus} ) ) |
| 262 | { | 262 | { |
| 263 | if ( defined( ${$desiredExitStatus}{$exitStatus} ) ) | 263 | if ( defined( ${$desiredExitStatus}{$exitStatus} ) ) |
| 264 | { | 264 | { |
| 265 | $testOutput = ${$desiredExitStatus}{$exitStatus}; | 265 | $testOutput = ${$desiredExitStatus}{$exitStatus}; |
| 266 | } | 266 | } |
| 267 | $desiredExitStatus = $exitStatus; | 267 | $desiredExitStatus = $exitStatus; |
| 268 | } | 268 | } |
| 269 | else | 269 | else |
| 270 | { | 270 | { |
| 271 | $desiredExitStatus = -1; | 271 | $desiredExitStatus = -1; |
| 272 | } | 272 | } |
| 273 | } | 273 | } |
| 274 | 274 | ||
| @@ -332,12 +332,12 @@ sub getTestParameter | |||
| 332 | my( $param, $envvar, $default, $brief, $scoped ); | 332 | my( $param, $envvar, $default, $brief, $scoped ); |
| 333 | my $new_style; | 333 | my $new_style; |
| 334 | if (scalar @_ <= 3) { | 334 | if (scalar @_ <= 3) { |
| 335 | ($param, $brief, $default) = @_; | 335 | ($param, $brief, $default) = @_; |
| 336 | $envvar = $param; | 336 | $envvar = $param; |
| 337 | $new_style = 1; | 337 | $new_style = 1; |
| 338 | } else { | 338 | } else { |
| 339 | ( $param, $envvar, $default, $brief, $scoped ) = @_; | 339 | ( $param, $envvar, $default, $brief, $scoped ) = @_; |
| 340 | $new_style = 0; | 340 | $new_style = 0; |
| 341 | } | 341 | } |
| 342 | 342 | ||
| 343 | # Apply default values for optional arguments | 343 | # Apply default values for optional arguments |
| @@ -394,7 +394,7 @@ sub getTestParameter | |||
| 394 | print STDERR "\n"; | 394 | print STDERR "\n"; |
| 395 | 395 | ||
| 396 | if ($userResponse =~ /^(na|none)$/) { | 396 | if ($userResponse =~ /^(na|none)$/) { |
| 397 | $userResponse = ""; | 397 | $userResponse = ""; |
| 398 | } | 398 | } |
| 399 | 399 | ||
| 400 | # define all user responses at global scope | 400 | # define all user responses at global scope |
| @@ -422,7 +422,7 @@ sub SearchCache | |||
| 422 | { | 422 | { |
| 423 | return $CACHE{$param}; | 423 | return $CACHE{$param}; |
| 424 | } | 424 | } |
| 425 | return undef; # Need this to say "nothing found" | 425 | return undef; # Need this to say "nothing found" |
| 426 | } | 426 | } |
| 427 | 427 | ||
| 428 | sub SetCacheParameter | 428 | sub SetCacheParameter |
| @@ -542,10 +542,10 @@ sub DetermineTestHarnessDirectory | |||
| 542 | push ( @dirs, "./tests"); | 542 | push ( @dirs, "./tests"); |
| 543 | } | 543 | } |
| 544 | 544 | ||
| 545 | if ( @dirs > 0 ) | 545 | if ( @dirs > 0 ) |
| 546 | { | 546 | { |
| 547 | return @dirs; | 547 | return @dirs; |
| 548 | } | 548 | } |
| 549 | 549 | ||
| 550 | # To be honest I don't understand which case satisfies the | 550 | # To be honest I don't understand which case satisfies the |
| 551 | # original code in test.pl : when $tstdir == `pwd` w.r.t. | 551 | # original code in test.pl : when $tstdir == `pwd` w.r.t. |
| @@ -611,73 +611,73 @@ sub TestsFrom | |||
| 611 | 611 | ||
| 612 | # All the new object oriented stuff below | 612 | # All the new object oriented stuff below |
| 613 | 613 | ||
| 614 | sub new { | 614 | sub new { |
| 615 | my $type = shift; | 615 | my $type = shift; |
| 616 | my $self = {}; | 616 | my $self = {}; |
| 617 | return bless $self, $type; | 617 | return bless $self, $type; |
| 618 | } | 618 | } |
| 619 | 619 | ||
| 620 | # Accessors | 620 | # Accessors |
| 621 | sub return_code { | 621 | sub return_code { |
| 622 | my $self = shift; | 622 | my $self = shift; |
| 623 | if (@_) { | 623 | if (@_) { |
| 624 | return $self->{return_code} = shift; | 624 | return $self->{return_code} = shift; |
| 625 | } else { | 625 | } else { |
| 626 | return $self->{return_code}; | 626 | return $self->{return_code}; |
| 627 | } | 627 | } |
| 628 | } | 628 | } |
| 629 | sub output { | 629 | sub output { |
| 630 | my $self = shift; | 630 | my $self = shift; |
| 631 | if (@_) { | 631 | if (@_) { |
| 632 | return $self->{output} = shift; | 632 | return $self->{output} = shift; |
| 633 | } else { | 633 | } else { |
| 634 | return $self->{output}; | 634 | return $self->{output}; |
| 635 | } | 635 | } |
| 636 | } | 636 | } |
| 637 | 637 | ||
| 638 | sub perf_output { | 638 | sub perf_output { |
| 639 | my $self = shift; | 639 | my $self = shift; |
| 640 | $_ = $self->{output}; | 640 | $_ = $self->{output}; |
| 641 | /\|(.*)$/; | 641 | /\|(.*)$/; |
| 642 | return $1 || ""; | 642 | return $1 || ""; |
| 643 | } | 643 | } |
| 644 | 644 | ||
| 645 | sub only_output { | 645 | sub only_output { |
| 646 | my $self = shift; | 646 | my $self = shift; |
| 647 | $_ = $self->{output}; | 647 | $_ = $self->{output}; |
| 648 | /(.*?)\|/; | 648 | /(.*?)\|/; |
| 649 | return $1 || ""; | 649 | return $1 || ""; |
| 650 | } | 650 | } |
| 651 | 651 | ||
| 652 | sub testCmd { | 652 | sub testCmd { |
| 653 | my $class = shift; | 653 | my $class = shift; |
| 654 | my $command = shift or die "No command passed to testCmd"; | 654 | my $command = shift or die "No command passed to testCmd"; |
| 655 | my $timeout = shift || 120; | 655 | my $timeout = shift || 120; |
| 656 | my $object = $class->new; | 656 | my $object = $class->new; |
| 657 | 657 | ||
| 658 | local $SIG{'ALRM'} = sub { die("timeout in command: $command"); }; | 658 | local $SIG{'ALRM'} = sub { die("timeout in command: $command"); }; |
| 659 | alarm($timeout); # no test should take longer than 120 seconds | 659 | alarm($timeout); # no test should take longer than 120 seconds |
| 660 | 660 | ||
| 661 | my $output = `$command`; | 661 | my $output = `$command`; |
| 662 | $object->return_code($? >> 8); | 662 | $object->return_code($? >> 8); |
| 663 | $_ = $? & 127; | 663 | $_ = $? & 127; |
| 664 | if ($_) { | 664 | if ($_) { |
| 665 | die "Got signal $_ for command $command"; | 665 | die "Got signal $_ for command $command"; |
| 666 | } | 666 | } |
| 667 | chomp $output; | 667 | chomp $output; |
| 668 | $object->output($output); | 668 | $object->output($output); |
| 669 | 669 | ||
| 670 | alarm(0); | 670 | alarm(0); |
| 671 | 671 | ||
| 672 | my ($pkg, $file, $line) = caller(0); | 672 | my ($pkg, $file, $line) = caller(0); |
| 673 | print "Testing: $command", $/; | 673 | print "Testing: $command", $/; |
| 674 | if ($ENV{'NPTEST_DEBUG'}) { | 674 | if ($ENV{'NPTEST_DEBUG'}) { |
| 675 | print "testCmd: Called from line $line in $file", $/; | 675 | print "testCmd: Called from line $line in $file", $/; |
| 676 | print "Output: ", $object->output, $/; | 676 | print "Output: ", $object->output, $/; |
| 677 | print "Return code: ", $object->return_code, $/; | 677 | print "Return code: ", $object->return_code, $/; |
| 678 | } | 678 | } |
| 679 | 679 | ||
| 680 | return $object; | 680 | return $object; |
| 681 | } | 681 | } |
| 682 | 682 | ||
| 683 | # do we have ipv6 | 683 | # do we have ipv6 |
