cvs commit: modperl-2.0/t/response/TestApache cookie.pm

[st...@apache.org]

stas        2003/09/22 16:33:18

  Added:       t/modperl cookie2.t
               t/response/TestModperl cookie2.pm
  Removed:     t/apache cookie.t
               t/response/TestApache cookie.pm
  Log:
  - move the perl-script cookie tests to be after modperl tests, also change
  the location to t/modperl/ as these aren't apache tests.
  - extend testing to check that the cookie value is not persitent between
  requests
  
  Revision  Changes    Path
  1.1                  modperl-2.0/t/modperl/cookie2.t
  
  Index: cookie2.t
  ===================================================================
  use strict;
  use warnings FATAL => 'all';
  
  # The Cookie HTTP header can be accessed via $r->headers_in and in certain
  # situations via $ENV{HTTP_COOKIE}.
  #
  # in this test we shouldn't be able get the cookie via %ENV,
  # since 'SetHandler modperl' doesn't set up CGI env var. unless the
  # handler calls "$r->subprocess_env" by itself
  #
  # since the test is run against the same interpreter we also test that
  # the cookie value doesn't persist if it makes it to %ENV.
  
  use Apache::Test;
  use Apache::TestUtil;
  use Apache::TestRequest;
  
  plan tests => 3;
  
  my $module   = 'TestModperl::cookie2';
  my $location = '/' . Apache::TestRequest::module2path($module);
  
  my %expected = 
  (
      header         => "header",
      subprocess_env => "subprocess_env",
      env            => '',
  );
  
  my @tests_ordered = qw(header subprocess_env env);
  
  t_debug "getting the same interp ID for $location";
  my $same_interp = Apache::TestRequest::same_interp_tie($location);
  
  my $skip = $same_interp ? 0 : 1;
  for my $test (@tests_ordered) {
      my $cookie = "key=$test";
  
      my $received = get_body($same_interp, \&GET,
                              "$location?$test", Cookie => $cookie);
      $skip++ unless defined $received;
      skip_not_same_interp(
          $skip,
          $expected{$test},
          $received,
          "perl-script+SetupEnv/cookie: $test"
      );
  }
  
  # if we fail to find the same interpreter, return undef (this is not
  # an error)
  sub get_body {
      my $res = eval {
          Apache::TestRequest::same_interp_do(@_);
      };
      return undef if $@ =~ /unable to find interp/;
      return $res->content if $res;
      die $@ if $@;
  }
  
  # make the tests resistant to a failure of finding the same perl
  # interpreter, which happens randomly and not an error.
  # the first argument is used to decide whether to skip the sub-test,
  # the rest of the arguments are passed to 'ok t_cmp';
  sub skip_not_same_interp {
      my $skip_cond = shift;
      if ($skip_cond) {
          skip "Skip couldn't find the same interpreter";
      }
      else {
          my($package, $filename, $line) = caller;
          # trick ok() into reporting the caller filename/line when a
          # sub-test fails in sok()
          return eval <<EOE;
  #line $line $filename
      ok &t_cmp;
  EOE
      }
  }
  
  
  
  1.1                  modperl-2.0/t/response/TestModperl/cookie2.pm
  
  Index: cookie2.pm
  ===================================================================
  package TestModperl::cookie2;
  
  use strict;
  use warnings FATAL => 'all';
  
  use Apache::TestTrace;
  
  use Apache::RequestRec ();
  use Apache::RequestIO ();
  
  use Apache::Const -compile => 'OK';
  
  sub access {
      my $r = shift;
  
      $r->subprocess_env if $r->args eq 'subprocess_env';
      my($key, $val) = cookie($r);
      die "I shouldn't get the cookie" if $r->args eq 'env' && defined $val;
  
      return Apache::OK;
  }
  
  sub handler {
      my $r = shift;
  
      my($key, $val) = cookie($r);
      $r->print($val) if defined $val;
  
      return Apache::OK;
  }
  
  sub cookie {
      my $r = shift;
  
      my $header = $r->headers_in->{Cookie} || '';
      my $env    = $ENV{HTTP_COOKIE} || $ENV{COOKIE} || ''; # from CGI::cookie2
      debug "cookie (" .$r->args . "): header: [$header], env: [$env]";
  
      return split '=', $r->args eq 'header' ? $header : $env;
  }
  
  1;
  
  __DATA__
  SetHandler modperl
  PerlModule          TestModperl::cookie2
  PerlInitHandler     Apache::TestHandler::same_interp_fixup
  PerlAccessHandler   TestModperl::cookie2::access
  PerlResponseHandler TestModperl::cookie2