stas 2003/08/21 17:41:32
Modified: ModPerl-Registry/t closure.t perlrun_require.t
special_blocks.t
t/modperl sameinterp.t
Log:
protect all tests using the same_interpreter setup from failures when the
same interpreter is not found.
Revision Changes Path
1.9 +28 -21 modperl-2.0/ModPerl-Registry/t/closure.t
Index: closure.t
===================================================================
RCS file: /home/cvs/modperl-2.0/ModPerl-Registry/t/closure.t,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- closure.t 8 Aug 2003 20:07:14 -0000 1.8
+++ closure.t 22 Aug 2003 00:41:32 -0000 1.9
@@ -35,10 +35,10 @@
my $same_interp = Apache::TestRequest::same_interp_tie($url);
# should be no closure effect, always returns 1
- my $first = req($same_interp, $url);
- my $second = req($same_interp, $url);
+ my $first = get_body($same_interp, $url);
+ my $second = get_body($same_interp, $url);
skip_not_same_intrep(
- scalar(grep defined, $first, $second),
+ (scalar(grep defined, $first, $second) != 2),
0,
$first && $second && ($second - $first),
"never the closure problem",
@@ -48,9 +48,9 @@
sleep_and_touch_file($path);
# it doesn't matter, since the script is not cached anyway
- my $third = req($same_interp, $url);
+ my $third = get_body($same_interp, $url);
skip_not_same_intrep(
- scalar(grep defined, $first, $second, $third),
+ (scalar(grep defined, $first, $second, $third) != 3),
1,
$third,
"never the closure problem",
@@ -67,10 +67,10 @@
# we don't know what other test has called this uri before, so we
# check the difference between two subsequent calls. In this case
# the difference should be 1.
- my $first = req($same_interp, $url);
- my $second = req($same_interp, $url);
+ my $first = get_body($same_interp, $url);
+ my $second = get_body($same_interp, $url);
skip_not_same_intrep(
- scalar(grep defined, $first, $second),
+ (scalar(grep defined, $first, $second) != 2),
1,
$first && $second && ($second - $first),
"the closure problem should exist",
@@ -80,9 +80,9 @@
sleep_and_touch_file($path);
# should not notice closure effect on the first request
- my $third = req($same_interp, $url);
+ my $third = get_body($same_interp, $url);
skip_not_same_intrep(
- scalar(grep defined, $first, $second, $third),
+ (scalar(grep defined, $first, $second, $third) != 3),
1,
$third,
"no closure on the first request",
@@ -99,10 +99,10 @@
# we don't know what other test has called this uri before, so we
# check the difference between two subsequent calls. In this case
# the difference should be 1.
- my $first = req($same_interp, $url);
- my $second = req($same_interp, $url);
+ my $first = get_body($same_interp, $url);
+ my $second = get_body($same_interp, $url);
skip_not_same_intrep(
- scalar(grep defined, $first, $second),
+ (scalar(grep defined, $first, $second) != 2),
1,
$first && $second && ($second - $first),
"the closure problem should exist",
@@ -112,9 +112,9 @@
sleep_and_touch_file($path);
# modification shouldn't be noticed
- my $third = req($same_interp, $url);
+ my $third = get_body($same_interp, $url);
skip_not_same_intrep(
- scalar(grep defined, $first, $second, $third),
+ (scalar(grep defined, $first, $second, $third) != 3),
1,
$first && $second && $third - $second,
"no reload on modification, the closure problem persists",
@@ -134,26 +134,33 @@
# if we fail to find the same interpreter, return undef (this is not
# an error)
-sub req {
+sub get_body {
my($same_interp, $url) = @_;
my $res = eval {
Apache::TestRequest::same_interp_do($same_interp, \&GET, $url);
};
- return undef if $@;
+ return undef if $@ =~ /unable to find interp/;
return $res->content if $res;
- die "failed to fetch $url";
+ die $@ if $@;
}
+
# make the tests resistant to a failure of finding the same perl
# interpreter, which happens randomly and not an error.
# the first argument is used to decide whether to skip the sub-test,
# the rest of the arguments are passed to 'ok t_cmp';
sub skip_not_same_intrep {
- my $do_not_skip_cond = shift;
- unless ($do_not_skip_cond) {
+ my $skip_cond = shift;
+ if ($skip_cond) {
skip "Skip couldn't find the same interpreter";
}
else {
- ok t_cmp(@_);
+ my($package, $filename, $line) = caller;
+ # trick ok() into reporting the caller filename/line when a
+ # sub-test fails in sok()
+ return eval <<EOE;
+#line $line $filename
+ ok &t_cmp;
+EOE
}
}
1.2 +34 -7 modperl-2.0/ModPerl-Registry/t/perlrun_require.t
Index: perlrun_require.t
===================================================================
RCS file: /home/cvs/modperl-2.0/ModPerl-Registry/t/perlrun_require.t,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- perlrun_require.t 6 Jan 2003 10:42:38 -0000 1.1
+++ perlrun_require.t 22 Aug 2003 00:41:32 -0000 1.2
@@ -14,16 +14,43 @@
for (1..2) {
# should not fail on the second request
- ok t_cmp(
+ my $res = get_body($same_interp, $url);
+ skip_not_same_intrep(
+ !defined($res),
"1",
- req($same_interp, $url),
+ $res,
"PerlRun requiering and external lib with subs",
- );
+ );
}
-sub req {
+# if we fail to find the same interpreter, return undef (this is not
+# an error)
+sub get_body {
my($same_interp, $url) = @_;
- my $res = Apache::TestRequest::same_interp_do($same_interp,
- \&GET, $url);
- return $res ? $res->content : undef;
+ my $res = eval {
+ Apache::TestRequest::same_interp_do($same_interp, \&GET, $url);
+ };
+ return undef if $@ =~ /unable to find interp/;
+ return $res->content if $res;
+ die $@ if $@;
+}
+
+# make the tests resistant to a failure of finding the same perl
+# interpreter, which happens randomly and not an error.
+# the first argument is used to decide whether to skip the sub-test,
+# the rest of the arguments are passed to 'ok t_cmp';
+sub skip_not_same_intrep {
+ my $skip_cond = shift;
+ if ($skip_cond) {
+ skip "Skip couldn't find the same interpreter";
+ }
+ else {
+ my($package, $filename, $line) = caller;
+ # trick ok() into reporting the caller filename/line when a
+ # sub-test fails in sok()
+ return eval <<EOE;
+#line $line $filename
+ ok &t_cmp;
+EOE
+ }
}
1.6 +114 -52 modperl-2.0/ModPerl-Registry/t/special_blocks.t
Index: special_blocks.t
===================================================================
RCS file: /home/cvs/modperl-2.0/ModPerl-Registry/t/special_blocks.t,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- special_blocks.t 6 Jun 2003 01:30:41 -0000 1.5
+++ special_blocks.t 22 Aug 2003 00:41:32 -0000 1.6
@@ -24,29 +24,45 @@
my $url = "/same_interp/$alias/special_blocks.pl";
my $same_interp = Apache::TestRequest::same_interp_tie($url);
- ok t_cmp(
- "begin ok",
- req($same_interp, "$url?begin"),
- "$modules{$alias} is running BEGIN blocks on the first req",
- );
-
- ok t_cmp(
- "begin ok",
- req($same_interp, "$url?begin"),
- "$modules{$alias} is running BEGIN blocks on the second req",
- );
-
- ok t_cmp(
- "end ok",
- req($same_interp, "$url?end"),
- "$modules{$alias} is running END blocks on the first req",
- );
-
- ok t_cmp(
- "end ok",
- req($same_interp, "$url?end"),
- "$modules{$alias} is running END blocks on the second req",
- );
+ # if one sub-test has failed to run on the same interpreter, skip
+ # the rest in the same group
+ my $skip = 0;
+
+ my $res = get_body($same_interp, "$url?begin");
+ $skip++ unless defined $res;
+ skip_not_same_intrep(
+ $skip,
+ "begin ok",
+ $res,
+ "$modules{$alias} is running BEGIN blocks on the first request",
+ );
+
+ $res = $skip ? undef : get_body($same_interp, "$url?begin");
+ $skip++ unless defined $res;
+ skip_not_same_intrep(
+ $skip,
+ "begin ok",
+ $res,
+ "$modules{$alias} is running BEGIN blocks on the second request",
+ );
+
+ $res = $skip ? undef : get_body($same_interp, "$url?end");
+ $skip++ unless defined $res;
+ skip_not_same_intrep(
+ $skip,
+ "end ok",
+ $res,
+ "$modules{$alias} is running END blocks on the third request",
+ );
+
+ $res = $skip ? undef : get_body($same_interp, "$url?end");
+ $skip++ unless defined $res;
+ skip_not_same_intrep(
+ $skip,
+ "end ok",
+ $res,
+ "$modules{$alias} is running END blocks on the fourth request",
+ );
}
# To properly test BEGIN/END blocks in registry implmentations
@@ -58,41 +74,87 @@
my $url = "/same_interp/$alias/special_blocks.pl";
my $same_interp = Apache::TestRequest::same_interp_tie($url);
+ # if one sub-test has failed to run on the same interpreter, skip
+ # the rest in the same group
+ my $skip = 0;
+
# clear the cache of the registry package for the script in $url
- req($same_interp, "$url?uncache");
+ my $res = get_body($same_interp, "$url?uncache");
+ $skip++ unless defined $res;
- ok t_cmp(
- "begin ok",
- req($same_interp, "$url?begin"),
- "$modules{$alias} is running BEGIN blocks on the first req",
- );
-
- ok t_cmp(
- "",
- req($same_interp, "$url?begin"),
- "$modules{$alias} is not running BEGIN blocks on the second req",
- );
+ $res = $skip ? undef : get_body($same_interp, "$url?begin");
+ $skip++ unless defined $res;
+ skip_not_same_intrep(
+ $skip,
+ "begin ok",
+ $res,
+ "$modules{$alias} is running BEGIN blocks on the first request",
+ );
+
+ $res = $skip ? undef : get_body($same_interp, "$url?begin");
+ $skip++ unless defined $res;
+ t_debug($res);
+ skip_not_same_intrep(
+ $skip,
+ "",
+ $res,
+ "$modules{$alias} is not running BEGIN blocks on the second request",
+ );
- # clear the cache of the registry package for the script in $url
- req($same_interp, "$url?uncache");
+ $same_interp = Apache::TestRequest::same_interp_tie($url);
+ $skip = 0;
- ok t_cmp(
- "end ok",
- req($same_interp, "$url?end"),
- "$modules{$alias} is running END blocks on the first req",
- );
-
- ok t_cmp(
- "end ok",
- req($same_interp, "$url?end"),
- "$modules{$alias} is running END blocks on the second req",
- );
+ # clear the cache of the registry package for the script in $url
+ $res = get_body($same_interp, "$url?uncache");
+ $skip++ unless defined $res;
+ $res = $skip ? undef : get_body($same_interp, "$url?end");
+ $skip++ unless defined $res;
+ skip_not_same_intrep(
+ $skip,
+ "end ok",
+ $res,
+ "$modules{$alias} is running END blocks on the first request",
+ );
+
+ $res = $skip ? undef : get_body($same_interp, "$url?end");
+ $skip++ unless defined $res;
+ skip_not_same_intrep(
+ $skip,
+ "end ok",
+ $res,
+ "$modules{$alias} is running END blocks on the second request",
+ );
}
-sub req {
+# if we fail to find the same interpreter, return undef (this is not
+# an error)
+sub get_body {
my($same_interp, $url) = @_;
- my $res = Apache::TestRequest::same_interp_do($same_interp,
- \&GET, $url);
- return $res->is_success ? $res->content : undef;
+ my $res = eval {
+ Apache::TestRequest::same_interp_do($same_interp, \&GET, $url);
+ };
+ return undef if $@ && $@ =~ /unable to find interp/;
+ die $@ if $@;
+ return $res->content if defined $res;
+}
+
+# make the tests resistant to a failure of finding the same perl
+# interpreter, which happens randomly and not an error.
+# the first argument is used to decide whether to skip the sub-test,
+# the rest of the arguments are passed to 'ok t_cmp';
+sub skip_not_same_intrep {
+ my $skip_cond = shift;
+ if ($skip_cond) {
+ skip "Skip couldn't find the same interpreter";
+ }
+ else {
+ my($package, $filename, $line) = caller;
+ # trick ok() into reporting the caller filename/line when a
+ # sub-test fails in sok()
+ return eval <<EOE;
+#line $line $filename
+ ok &t_cmp;
+EOE
+ }
}
1.4 +53 -13 modperl-2.0/t/modperl/sameinterp.t
Index: sameinterp.t
===================================================================
RCS file: /home/cvs/modperl-2.0/t/modperl/sameinterp.t,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- sameinterp.t 18 Apr 2003 06:18:58 -0000 1.3
+++ sameinterp.t 22 Aug 2003 00:41:32 -0000 1.4
@@ -18,15 +18,18 @@
ok $same_interp;
my $value = 1;
+ my $skip = 0;
# test GET over the same same_interp
for (1..2) {
$value++;
- my $res = Apache::TestRequest::same_interp_do($same_interp, \&GET,
- $url, foo => 'bar');
- ok t_cmp(
+ my $res = req($same_interp, \&GET, $url, foo => 'bar');
+ $skip++ unless defined $res;
+ skip_not_same_intrep(
+ $skip,
$value,
defined $res && $res->content,
- "GET over the same interp");
+ "GET over the same interp"
+ );
}
}
@@ -36,16 +39,18 @@
ok $same_interp;
my $value = 1;
+ my $skip = 0;
for (1..2) {
$value++;
my $content = join ' ', 'ok', $_ + 3;
- my $res = Apache::TestRequest::same_interp_do($same_interp, \&POST,
- $url,
- content => $content);
- ok t_cmp(
+ my $res = req($same_interp, \&POST, $url, content => $content);
+ $skip++ unless defined $res;
+ skip_not_same_intrep(
+ $skip,
$value,
defined $res && $res->content,
- "POST over the same interp");
+ "POST over the same interp"
+ );
}
}
@@ -55,13 +60,48 @@
ok $same_interp;
my $value = 1;
+ my $skip = 0;
for (1..2) {
$value++;
- my $res = Apache::TestRequest::same_interp_do($same_interp, \&HEAD,
- $url);
- ok t_cmp(
+ my $res = req($same_interp, \&HEAD, $url);
+ $skip++ unless defined $res;
+ skip_not_same_intrep(
+ $skip,
$same_interp,
defined $res && $res->header(Apache::TestRequest::INTERP_KEY),
- "HEAD over the same interp");
+ "HEAD over the same interp"
+ );
+ }
+}
+
+# if we fail to find the same interpreter, return undef (this is not
+# an error)
+sub req {
+ my($same_interp, $url) = @_;
+ my $res = eval {
+ Apache::TestRequest::same_interp_do(@_);
+ };
+ return undef if $@ && $@ =~ /unable to find interp/;
+ die $@ if $@;
+ return $res;
+}
+
+# make the tests resistant to a failure of finding the same perl
+# interpreter, which happens randomly and not an error.
+# the first argument is used to decide whether to skip the sub-test,
+# the rest of the arguments are passed to 'ok t_cmp';
+sub skip_not_same_intrep {
+ my $skip_cond = shift;
+ if ($skip_cond) {
+ skip "Skip couldn't find the same interpreter";
+ }
+ else {
+ my($package, $filename, $line) = caller;
+ # trick ok() into reporting the caller filename/line when a
+ # sub-test fails in sok()
+ return eval <<EOE;
+#line $line $filename
+ ok &t_cmp;
+EOE
}
}
