home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / TestHandler.pm < prev    next >
Encoding:
Perl POD Document  |  2004-03-08  |  3.1 KB  |  99 lines
  1. # Copyright 2001-2004 The Apache Software Foundation
  2. #
  3. # Licensed under the Apache License, Version 2.0 (the "License");
  4. # you may not use this file except in compliance with the License.
  5. # You may obtain a copy of the License at
  6. #
  7. #     http://www.apache.org/licenses/LICENSE-2.0
  8. #
  9. # Unless required by applicable law or agreed to in writing, software
  10. # distributed under the License is distributed on an "AS IS" BASIS,
  11. # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  12. # See the License for the specific language governing permissions and
  13. # limitations under the License.
  14. #
  15. package Apache::TestHandler;
  16.  
  17. use strict;
  18. use warnings FATAL => 'all';
  19.  
  20. use Apache::Test ();
  21. use Apache::TestRequest ();
  22.  
  23. use Apache::Const -compile => qw(OK NOT_FOUND SERVER_ERROR);
  24.  
  25. #some utility handlers for testing hooks other than response
  26. #see modperl-2.0/t/hooks/TestHooks/authen.pm
  27.  
  28. #compat with 1.xx
  29. my $send_http_header = Apache->can('send_http_header') || sub {};
  30. my $print = Apache->can('print') || Apache::RequestRec->can('puts');
  31.  
  32. sub ok {
  33.     my $r = shift;
  34.     $r->$send_http_header;
  35.     $r->content_type('text/plain');
  36.     $r->$print("ok");
  37.     0;
  38. }
  39.  
  40. sub ok1 {
  41.     my $r = shift;
  42.     Apache::Test::plan($r, tests => 1);
  43.     Apache::Test::ok(1);
  44.     0;
  45. }
  46.  
  47. # a fixup handler to be used when a few requests need to be run
  48. # against the same perl interpreter, in situations where there is more
  49. # than one client running. For an example of use see
  50. # modperl-2.0/t/response/TestModperl/interp.pm and
  51. # modperl-2.0/t/modperl/interp.t
  52. #
  53. # this handler expects the header X-PerlInterpreter in the request
  54. # - if none is set, Apache::SERVER_ERROR is returned
  55. # - if its value eq 'tie', instance's global UUID is assigned and
  56. #   returned via the same header
  57. # - otherwise if its value is not the same the stored instance's
  58. #   global UUID Apache::NOT_FOUND is returned
  59. #
  60. # in addition $same_interp_counter counts how many times this instance of
  61. # pi has been called after the reset 'tie' request (inclusive), this
  62. # value can be retrieved with Apache::TestHandler::same_interp_counter()
  63. my $same_interp_id = "";
  64. # keep track of how many times this instance was called after the reset
  65. my $same_interp_counter = 0;
  66. sub same_interp_counter { $same_interp_counter }
  67. sub same_interp_fixup {
  68.     my $r = shift;
  69.     my $interp = $r->headers_in->get(Apache::TestRequest::INTERP_KEY);
  70.  
  71.     unless ($interp) {
  72.         # shouldn't be requesting this without an INTERP header
  73.         return Apache::SERVER_ERROR;
  74.     }
  75.  
  76.     my $id = $same_interp_id;
  77.     if ($interp eq 'tie') { #first request for an interpreter instance
  78.         # unique id for this instance
  79.         $same_interp_id = $id =
  80.             unpack "H*", pack "Nnn", time, $$, int(rand(60000));
  81.         $same_interp_counter = 0; #reset the counter
  82.     }
  83.     elsif ($interp ne $same_interp_id) {
  84.         # this is not the request interpreter instance
  85.         return Apache::NOT_FOUND;
  86.     }
  87.  
  88.     $same_interp_counter++;
  89.  
  90.     # so client can save the created instance id or check the existing
  91.     # value
  92.     $r->headers_out->set(Apache::TestRequest::INTERP_KEY, $id);
  93.  
  94.     return Apache::OK;
  95. }
  96.  
  97. 1;
  98. __END__
  99.