home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / TestHandler.pm < prev    next >
Encoding:
Perl POD Document  |  2001-10-18  |  2.6 KB  |  85 lines
  1. package Apache::TestHandler;
  2.  
  3. use strict;
  4. use warnings FATAL => 'all';
  5.  
  6. use Apache::Test ();
  7. use Apache::TestRequest ();
  8.  
  9. use Apache::Const -compile => qw(OK NOT_FOUND SERVER_ERROR);
  10.  
  11. #some utility handlers for testing hooks other than response
  12. #see modperl-2.0/t/hooks/TestHooks/authen.pm
  13.  
  14. #compat with 1.xx
  15. my $send_http_header = Apache->can('send_http_header') || sub {};
  16. my $print = Apache->can('print') || Apache::RequestRec->can('puts');
  17.  
  18. sub ok {
  19.     my $r = shift;
  20.     $r->$send_http_header;
  21.     $r->content_type('text/plain');
  22.     $r->$print("ok");
  23.     0;
  24. }
  25.  
  26. sub ok1 {
  27.     my $r = shift;
  28.     Apache::Test::plan($r, tests => 1);
  29.     Apache::Test::ok(1);
  30.     0;
  31. }
  32.  
  33. # a fixup handler to be used when a few requests need to be run
  34. # against the same perl interpreter, in situations where there is more
  35. # than one client running. For an example of use see
  36. # modperl-2.0/t/response/TestModperl/interp.pm and
  37. # modperl-2.0/t/modperl/interp.t
  38. #
  39. # this handler expects the header X-PerlInterpreter in the request
  40. # - if none is set, Apache::SERVER_ERROR is returned
  41. # - if its value eq 'tie', instance's global UUID is assigned and
  42. #   returned via the same header
  43. # - otherwise if its value is not the same the stored instance's
  44. #   global UUID Apache::NOT_FOUND is returned
  45. #
  46. # in addition $same_interp_counter counts how many times this instance of
  47. # pi has been called after the reset 'tie' request (inclusive), this
  48. # value can be retrieved with Apache::TestHandler::same_interp_counter()
  49. my $same_interp_id = "";
  50. # keep track of how many times this instance was called after the reset
  51. my $same_interp_counter = 0;
  52. sub same_interp_counter { $same_interp_counter }
  53. sub same_interp_fixup {
  54.     my $r = shift;
  55.     my $interp = $r->headers_in->get(Apache::TestRequest::INTERP_KEY);
  56.  
  57.     unless ($interp) {
  58.         # shouldn't be requesting this without an INTERP header
  59.         return Apache::SERVER_ERROR;
  60.     }
  61.  
  62.     my $id = $same_interp_id;
  63.     if ($interp eq 'tie') { #first request for an interpreter instance
  64.         # unique id for this instance
  65.         require APR::UUID;
  66.         $same_interp_id = $id = APR::UUID->new->format;
  67.         $same_interp_counter = 0; #reset the counter
  68.     }
  69.     elsif ($interp ne $same_interp_id) {
  70.         # this is not the request interpreter instance
  71.         return Apache::NOT_FOUND;
  72.     }
  73.  
  74.     $same_interp_counter++;
  75.  
  76.     # so client can save the created instance id or check the existing
  77.     # value
  78.     $r->headers_out->set(Apache::TestRequest::INTERP_KEY, $id);
  79.  
  80.     return Apache::OK;
  81. }
  82.  
  83. 1;
  84. __END__
  85.