stas 01/11/08 17:30:35
Modified: perl-framework/Apache-Test/lib/Apache Test.pm
perl-framework/t/apache byterange.t getfile.t
Log:
- print the reason when a test is skipped
o automatically for the built in condition functions
o lets user provide his own condition funcs and reasoning for custom
requirements
- adjust tests to use the skip_unless()
Revision Changes Path
1.28 +64 -10 httpd-test/perl-framework/Apache-Test/lib/Apache/Test.pm
Index: Test.pm
===================================================================
RCS file: /home/cvs/httpd-test/perl-framework/Apache-Test/lib/Apache/Test.pm,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- Test.pm 2001/10/20 10:35:33 1.27
+++ Test.pm 2001/11/09 01:30:35 1.28
@@ -8,14 +8,15 @@
use Config;
use Apache::TestConfig ();
-use vars qw(@ISA @EXPORT $VERSION %SubTests);
+use vars qw(@ISA @EXPORT $VERSION %SubTests @SkipReasons);
@ISA = qw(Exporter);
[EMAIL PROTECTED] = qw(ok skip sok plan have_lwp have_http11 have_cgi
- have_module have_apache have_perl);
[EMAIL PROTECTED] = qw(ok skip sok plan skip_unless have_lwp have_http11
+ have_cgi have_module have_apache have_perl);
$VERSION = '0.01';
%SubTests = ();
[EMAIL PROTECTED] = ();
if (my $subtests = $ENV{HTTPD_TEST_SUBTESTS}) {
%SubTests = map { $_, 1 } split /\s+/, $subtests;
@@ -67,10 +68,28 @@
test_pm_refresh();
}
-#caller will need to have required Apache::TestRequest
-*have_http11 = \&Apache::TestRequest::install_http11;
-*have_lwp = \&Apache::TestRequest::has_lwp;
+sub have_http11 {
+ require Apache::TestRequest;
+ if (Apache::TestRequest::install_http11()) {
+ return 1;
+ }
+ else {
+ push @SkipReasons, "LWP cannot handle HTTP 1.1";
+ return 0;
+ }
+}
+sub have_lwp {
+ require Apache::TestRequest;
+ if (Apache::TestRequest::has_lwp()) {
+ return 1;
+ }
+ else {
+ push @SkipReasons, "must have LWP installed";
+ return 0;
+ }
+}
+
sub plan {
init_test_pm(shift) if ref $_[0];
@@ -90,49 +109,83 @@
#plan tests $n, [qw(php4 rewrite)];
$meets_condition = have_module($condition);
}
+ else {
+ die "don't know how to handle a condition of type $ref";
+ }
}
else {
# we have the verdict already: true/false
$meets_condition = $condition ? 1 : 0;
}
+ # tryint to emulate a dual variable (ala errno)
unless ($meets_condition) {
- print "1..0\n";
+ push @SkipReasons, "no reason given" unless @SkipReasons;
+ print "1..0 # skipped: " . join(', ', @SkipReasons) . "\n";
exit; #XXX: Apache->exit
}
}
+ @SkipReasons = (); # reset
Test::plan(@_);
}
+sub skip_unless {
+ my $condition = shift;
+ my $reason = shift || "no reason given";
+
+ if (ref $condition eq 'CODE' and $condition->()) {
+ return 1;
+ }
+ else {
+ push @SkipReasons, $reason;
+ return 0;
+ }
+}
+
sub have_module {
my $cfg = config();
my @modules = ref($_[0]) ? @{ $_[0] } : @_;
+ my @reasons = ();
for (@modules) {
+ my $reason;
if (/^[a-z0-9_]+$/) {
my $mod = $_;
$mod = 'mod_' . $mod unless $mod =~ /^mod_/;
$mod .= '.c' unless $mod =~ /\.c$/;
next if $cfg->{modules}->{$mod};
+ if (exists $cfg->{cmodules_disabled}->{$mod}) {
+ push @SkipReasons, $cfg->{cmodules_disabled}->{$mod};
+ return 0;
+ }
}
die "bogus module name $_" unless /^[\w:.]+$/;
eval "require $_";
#print $@ if $@;
- return 0 if $@;
+ if ($@) {
+ push @SkipReasons, "cannot find $_";
+ return 0;
+ }
}
return 1;
}
sub have_cgi {
- [have_module('cgi') || have_module('cgid')];
+ have_module('cgi') || have_module('cgid');
}
sub have_apache {
my $version = shift;
my $cfg = Apache::Test::config();
- $cfg->{server}->{rev} == $version;
+ if ($cfg->{server}->{rev} == $version) {
+ return 1;
+ }
+ else {
+ push @SkipReasons, "need apache $version, but this is
$cfg->{server}->{rev}";
+ return 0;
+ }
}
sub have_perl {
@@ -141,6 +194,7 @@
for my $key ($thing, "use$thing") {
return 1 if $Config{$key} and $Config{$key} eq 'define';
}
+ push @SkipReasons, "Perl was built with neither $thing nor use$thing";
return 0;
}
1.3 +2 -1 httpd-test/perl-framework/t/apache/byterange.t
Index: byterange.t
===================================================================
RCS file: /home/cvs/httpd-test/perl-framework/t/apache/byterange.t,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- byterange.t 2001/09/10 17:12:37 1.2
+++ byterange.t 2001/11/09 01:30:35 1.3
@@ -25,7 +25,8 @@
my %other_files;
-plan tests => @pods + keys(%other_files), sub { $perlpod };
+plan tests => @pods + keys(%other_files),
+ skip_unless(sub { $vars->{perlpod} }, "dir $vars->{perlpod} doesn't
exist");
for my $url (keys %other_files) {
verify($url, $other_files{$url});
1.6 +2 -1 httpd-test/perl-framework/t/apache/getfile.t
Index: getfile.t
===================================================================
RCS file: /home/cvs/httpd-test/perl-framework/t/apache/getfile.t,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- getfile.t 2001/09/10 17:12:37 1.5
+++ getfile.t 2001/11/09 01:30:35 1.6
@@ -20,7 +20,8 @@
("/getfiles-binary-$_", $vars->{$_})
} qw(httpd perl);
-plan tests => @pods + keys(%other_files), sub { $perlpod };
+plan tests => @pods + keys(%other_files),
+ skip_unless(sub { $vars->{perlpod} }, "dir $vars->{perlpod} doesn't
exist");
my $location = "/getfiles-perl-pod";
