"Fossies" - the Fresh Open Source Software Archive

Member "mod_perl-2.0.11/Apache-Test/lib/Apache/TestHandler.pm" (5 Oct 2019, 5186 Bytes) of package /linux/www/apache_httpd_modules/mod_perl-2.0.11.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 # Licensed to the Apache Software Foundation (ASF) under one or more
    2 # contributor license agreements.  See the NOTICE file distributed with
    3 # this work for additional information regarding copyright ownership.
    4 # The ASF licenses this file to You under the Apache License, Version 2.0
    5 # (the "License"); you may not use this file except in compliance with
    6 # the License.  You may obtain a copy of the License at
    7 #
    8 #     http://www.apache.org/licenses/LICENSE-2.0
    9 #
   10 # Unless required by applicable law or agreed to in writing, software
   11 # distributed under the License is distributed on an "AS IS" BASIS,
   12 # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
   13 # See the License for the specific language governing permissions and
   14 # limitations under the License.
   15 #
   16 package Apache::TestHandler;
   17 
   18 use strict;
   19 use warnings FATAL => 'all';
   20 
   21 use Apache::Test qw/!:DEFAULT/; # call import() to tell about -withouttestmore
   22 use Apache::TestRequest ();
   23 
   24 use Apache2::Const -compile => qw(OK NOT_FOUND SERVER_ERROR);
   25 
   26 #some utility handlers for testing hooks other than response
   27 #see modperl-2.0/t/hooks/TestHooks/authen.pm
   28 
   29 if ($ENV{MOD_PERL} && require mod_perl2) {
   30     require Apache2::RequestRec; # content_type
   31     require Apache2::RequestIO;  # puts
   32 }
   33 
   34 #compat with 1.xx
   35 my $send_http_header = Apache->can('send_http_header') || sub {};
   36 my $print = Apache2->can('print') || Apache2::RequestRec->can('puts');
   37 
   38 sub ok {
   39     my ($r, $boolean) = @_;
   40     $r->$send_http_header;
   41     $r->content_type('text/plain');
   42     $r->$print((@_>1 && !$boolean ? "not " : '')."ok");
   43     0;
   44 }
   45 
   46 sub ok1 {
   47     my ($r, $boolean) = @_;
   48     Apache::Test::plan($r, tests => 1);
   49     Apache::Test::ok(@_==1 || $boolean);
   50     0;
   51 }
   52 
   53 # a fixup handler to be used when a few requests need to be run
   54 # against the same perl interpreter, in situations where there is more
   55 # than one client running. For an example of use see
   56 # modperl-2.0/t/response/TestModperl/interp.pm and
   57 # modperl-2.0/t/modperl/interp.t
   58 #
   59 # this handler expects the header X-PerlInterpreter in the request
   60 # - if none is set, Apache::SERVER_ERROR is returned
   61 # - if its value eq 'tie', instance's global UUID is assigned and
   62 #   returned via the same header
   63 # - otherwise if its value is not the same the stored instance's
   64 #   global UUID Apache::NOT_FOUND is returned
   65 #
   66 # in addition $same_interp_counter counts how many times this instance of
   67 # pi has been called after the reset 'tie' request (inclusive), this
   68 # value can be retrieved with Apache::TestHandler::same_interp_counter()
   69 my $same_interp_id = "";
   70 # keep track of how many times this instance was called after the reset
   71 my $same_interp_counter = 0;
   72 sub same_interp_counter { $same_interp_counter }
   73 sub same_interp_fixup {
   74     my $r = shift;
   75     my $interp = $r->headers_in->get(Apache::TestRequest::INTERP_KEY);
   76 
   77     unless ($interp) {
   78         # shouldn't be requesting this without an INTERP header
   79         die "can't find the interpreter key";
   80     }
   81 
   82     my $id = $same_interp_id;
   83     if ($interp eq 'tie') { #first request for an interpreter instance
   84         # unique id for this instance
   85         $same_interp_id = $id =
   86             unpack "H*", pack "Nnn", time, $$, int(rand(60000));
   87         $same_interp_counter = 0; #reset the counter
   88     }
   89     elsif ($interp ne $same_interp_id) {
   90         # this is not the request interpreter instance
   91         return Apache2::Const::NOT_FOUND;
   92     }
   93 
   94     $same_interp_counter++;
   95 
   96     # so client can save the created instance id or check the existing
   97     # value
   98     $r->headers_out->set(Apache::TestRequest::INTERP_KEY, $id);
   99 
  100     return Apache2::Const::OK;
  101 }
  102 
  103 1;
  104 __END__
  105 
  106 =encoding utf8
  107 
  108 =head1 NAME
  109 
  110 Apache::TestHandler - a few response handlers and helpers
  111 
  112 =head1 SYNOPSIS
  113 
  114     package My::Test;
  115     use Apache::TestHandler ();
  116     sub handler {
  117         my ($r) = @_;
  118         my $result = do_my_test;
  119         Apache::TestHandler::ok1 $r, $result;
  120     }
  121 
  122     sub handler2 {
  123         my ($r) = @_;
  124         my $result = do_my_test;
  125         Apache::TestHandler::ok $r, $result;
  126     }
  127 
  128 =head1 DESCRIPTION
  129 
  130 C<Apache::TestHandler> provides 2 very simple response handler.
  131 
  132 =head1 FUNCTIONS
  133 
  134 =over 4
  135 
  136 =item ok $r, $boolean
  137 
  138 The handler simply prints out C<ok> or C<not ok> depending on the
  139 optional C<$boolean> parameter.
  140 
  141 If C<$boolean> is omitted C<true> is assumed.
  142 
  143 =item ok1 $r, $boolean
  144 
  145 This handler implements a simple response-only test. It can be used on its
  146 own to check if for a certain URI the response phase is reached. Or it
  147 can be called like a normal function to print out the test result. The
  148 client side is automatically created as described in
  149 L<http://perl.apache.org/docs/general/testing/testing.html#Developing_Response_only_Part_of_a_Test>.
  150 
  151 C<$boolean> is optional. If omitted C<true> is assumed.
  152 
  153 =item same_interp_counter
  154 
  155 =item same_interp_fixup
  156 
  157 TODO
  158 
  159 =back
  160 
  161 =head1 SEE ALSO
  162 
  163 The Apache-Test tutorial:
  164 L<http://perl.apache.org/docs/general/testing/testing.html>.
  165 
  166 L<Apache::Test>.
  167 
  168 =head1 AUTHOR
  169 
  170 Doug MacEachern, Geoffrey Young, Stas Bekman, Torsten Förtsch and others.
  171 
  172 Questions can be asked at the test-dev <at> httpd.apache.org list
  173 For more information see: http://httpd.apache.org/test/.
  174 
  175 =cut