perl-modperl-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From s...@apache.org
Subject cvs commit: modperl-2.0/t/modperl sameinterp.t
Date Fri, 22 Aug 2003 00:41:32 GMT
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
       }
   }
  
  
  

Mime
View raw message