cvs commit: modperl-2.0/t/response/TestModperl interp.pm

[dougm]

dougm       01/10/16 20:20:02

  Added:       t/modperl interp.t
               t/response/TestModperl interp.pm
  Log:
  add a test that uses the same interpreter each time
  
  Revision  Changes    Path
  1.1                  modperl-2.0/t/modperl/interp.t
  
  Index: interp.t
  ===================================================================
  use strict;
  use warnings FATAL => 'all';
  
  use Apache::Test;
  use Apache::TestRequest;
  
  use constant INTERP => 'X-PerlInterpreter';
  
  plan tests => 3, \&have_lwp;
  
  my $url = "/TestModperl::interp";
  
  #request an interpreter instance
  my $res = GET $url, INTERP, 'init';
  
  #use this interpreter id to select the same interpreter in requests below
  my $interp = $res->header(INTERP);
  
  print "using interp: $interp\n";
  
  print $res->content;
  
  my $found_interp = "";
  my $find_interp = sub {
      $res->code == 200 and (($found_interp = $res->header(INTERP)) eq $interp);
  };
  
  for (1..2) {
      my $times = 0;
  
      do {
          #loop until we get a response from our interpreter instance
          $res = GET $url, INTERP, $interp;
  
          #trace info
          unless ($find_interp->()) {
              print $found_interp ?
                "wrong interpreter: $found_interp\n" :
                "no interpreter\n";
          }
  
          if ($times++ > 15) { #prevent endless loop
              die "unable to find interp $interp\n";
          }
      } while (not $find_interp->());
  
      print $res->content; #ok $value++
  }
  
  
  
  
  1.1                  modperl-2.0/t/response/TestModperl/interp.pm
  
  Index: interp.pm
  ===================================================================
  package TestModperl::interp;
  
  use warnings FATAL => 'all';
  use strict;
  
  use APR::UUID ();
  use Apache::Const -compile => qw(OK NOT_FOUND SERVER_ERROR);
  
  use constant INTERP => 'X-PerlInterpreter';
  
  my $interp_id = "";
  my $value = 0;
  
  sub fixup {
      my $r = shift;
      my $interp = $r->headers_in->get(INTERP);
      my $rc = Apache::OK;
  
      unless ($interp) {
          #shouldn't be requesting this without an INTERP header
          return Apache::SERVER_ERROR;
      }
  
      my $id = $interp_id;
      if ($interp eq 'init') { #first request for an interpreter instance
          #unique id for this instance
          $interp_id = $id = APR::UUID->new->format;
          $value = 0; #reset our global data
      }
      elsif ($interp ne $interp_id) {
          #this is not the request interpreter instance
          $rc = Apache::NOT_FOUND;
      }
  
      #so client can save the created instance id or check the existing value
      $r->headers_out->set(INTERP, $id);
  
      return $rc;
  }
  
  sub handler {
      my $r = shift;
  
      #test the actual global data
      $value++;
      $r->puts("ok $value\n");
  
      Apache::OK;
  }
  
  1;
  __END__
  PerlFixupHandler TestModperl::interp::fixup