cvs commit: httpd-test/perl-framework/Apache-Test/lib/Apache TestHandler.pm TestRequest.pm

[st...@apache.org]

stas        01/10/18 19:08:17

  Modified:    perl-framework/Apache-Test/lib/Apache TestHandler.pm
                        TestRequest.pm
  Log:
  - add a fixup handler that can be used for making sure that a few requests
  will be served by the same perl interpreter, by the tests
  - add client functions that can request an interpreter instance and in the
  following requests ask for the same interpreter.
  
  Revision  Changes    Path
  1.2       +57 -0     httpd-test/perl-framework/Apache-Test/lib/Apache/TestHandler.pm
  
  Index: TestHandler.pm
  ===================================================================
  RCS file: /home/cvs/httpd-test/perl-framework/Apache-Test/lib/Apache/TestHandler.pm,v
  retrieving revision 1.1
  retrieving revision 1.2
  diff -u -r1.1 -r1.2
  --- TestHandler.pm	2001/04/02 09:00:28	1.1
  +++ TestHandler.pm	2001/10/19 02:08:17	1.2
  @@ -1,6 +1,12 @@
   package Apache::TestHandler;
   
  +use strict;
  +use warnings FATAL => 'all';
  +
   use Apache::Test ();
  +use Apache::TestRequest ();
  +
  +use Apache::Const -compile => qw(OK NOT_FOUND SERVER_ERROR);
   
   #some utility handlers for testing hooks other than response
   #see modperl-2.0/t/hooks/TestHooks/authen.pm
  @@ -24,4 +30,55 @@
       0;
   }
   
  +# a fixup handler to be used when a few requests need to be run
  +# against the same perl interpreter, in situations where there is more
  +# than one client running. For an example of use see
  +# modperl-2.0/t/response/TestModperl/interp.pm and
  +# modperl-2.0/t/modperl/interp.t
  +#
  +# this handler expects the header X-PerlInterpreter in the request
  +# - if none is set, Apache::SERVER_ERROR is returned
  +# - if its value eq 'tie', instance's global UUID is assigned and
  +#   returned via the same header
  +# - otherwise if its value is not the same the stored instance's
  +#   global UUID Apache::NOT_FOUND is returned
  +#
  +# in addition $same_interp_counter counts how many times this instance of
  +# pi has been called after the reset 'tie' request (inclusive), this
  +# value can be retrieved with Apache::TestHandler::same_interp_counter()
  +my $same_interp_id = "";
  +# keep track of how many times this instance was called after the reset
  +my $same_interp_counter = 0;
  +sub same_interp_counter { $same_interp_counter }
  +sub same_interp_fixup {
  +    my $r = shift;
  +    my $interp = $r->headers_in->get(Apache::TestRequest::INTERP_KEY);
  +
  +    unless ($interp) {
  +        # shouldn't be requesting this without an INTERP header
  +        return Apache::SERVER_ERROR;
  +    }
  +
  +    my $id = $same_interp_id;
  +    if ($interp eq 'tie') { #first request for an interpreter instance
  +        # unique id for this instance
  +        require APR::UUID;
  +        $same_interp_id = $id = APR::UUID->new->format;
  +        $same_interp_counter = 0; #reset the counter
  +    }
  +    elsif ($interp ne $same_interp_id) {
  +        # this is not the request interpreter instance
  +        return Apache::NOT_FOUND;
  +    }
  +
  +    $same_interp_counter++;
  +
  +    # so client can save the created instance id or check the existing
  +    # value
  +    $r->headers_out->set(Apache::TestRequest::INTERP_KEY, $id);
  +
  +    return Apache::OK;
  +}
  +
   1;
  +__END__
  
  
  
  1.46      +47 -0     httpd-test/perl-framework/Apache-Test/lib/Apache/TestRequest.pm
  
  Index: TestRequest.pm
  ===================================================================
  RCS file: /home/cvs/httpd-test/perl-framework/Apache-Test/lib/Apache/TestRequest.pm,v
  retrieving revision 1.45
  retrieving revision 1.46
  diff -u -r1.45 -r1.46
  --- TestRequest.pm	2001/10/16 20:30:57	1.45
  +++ TestRequest.pm	2001/10/19 02:08:17	1.46
  @@ -8,6 +8,9 @@
   use Apache::Test ();
   use Apache::TestConfig ();
   
  +use constant TRY_TIMES => 50;
  +use constant INTERP_KEY => 'X-PerlInterpreter';
  +
   my $have_lwp = eval {
       require LWP::UserAgent;
       require HTTP::Request::Common;
  @@ -401,6 +404,50 @@
       my $obj = shift;
       ref($obj) ? $obj->as_string : $obj;
   }
  +
  +# request an interpreter instance and use this interpreter id to
  +# select the same interpreter in requests below
  +sub same_interp_tie {
  +    my($url) = @_;
  +
  +    my $res = GET($url, INTERP_KEY, 'tie');
  +
  +    my $same_interp = $res->header(INTERP_KEY);
  +
  +    return $same_interp;
  +}
  +
  +# run the request though the selected perl interpreter, by polling
  +# until we found it
  +# currently supports only GET, HEAD, PUT, POST subs
  +sub same_interp_do {
  +    my($same_interp, $sub, $url, @args) = @_;
  +    push @args, (INTERP_KEY, $same_interp);
  +
  +    my $res      = '';
  +    my $times    = 0;
  +    my $found_same_interp = '';
  +    do {
  +        #loop until we get a response from our interpreter instance
  +        $res = $sub->($url, @args);
  +
  +        if ($res->code == 200) {
  +            $found_same_interp = $res->header(INTERP_KEY);
  +        }
  +
  +        unless ($found_same_interp eq $same_interp) {
  +            warn "found wrong same_interp: $found_same_interp";
  +            $found_same_interp = '';
  +        }
  +
  +        if ($times++ > TRY_TIMES) { #prevent endless loop
  +            die "unable to find interp $same_interp\n";
  +        }
  +    } until ($found_same_interp);
  +
  +    return $found_same_interp ? $res : undef;
  +}
  +
   
   sub set_client_cert {
       my $name = shift;