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

[stas]

stas        2003/10/15 01:04:44

  Added:       t/modperl request_rec_perlio_api.t
               t/response/TestModperl request_rec_perlio_api.pm
  Log:
  add STD* ":Apache" perlio overriding/restoring tests
  
  Revision  Changes    Path
  1.1                  modperl-2.0/t/modperl/request_rec_perlio_api.t
  
  Index: request_rec_perlio_api.t
  ===================================================================
  use strict;
  use warnings FATAL => 'all';
  
  # test internal redirects originating from 'SetHandler modperl' and
  # 'SetHandler perl-script' main handlers, and sub-requests handled by
  # the handlers of the same and the opposite kind
  
  use Apache::Test;
  use Apache::TestUtil;
  use Apache::TestRequest;
  
  use Config;
  
  my $uri = "/TestModperl__request_rec_perlio_api";
  
  plan tests => 2, have { "perl $]: TIEd IO is used instead of PerlIO"
                              => ($] >= 5.008 && $Config{useperlio}) };
  
  
  {
      my $content  = join "", 'a'..'j', 'k'..'t';
      my $location = "$uri?STDIN";
      my $expected = join "", 'a'..'j', "<samba>", 'k'..'t';
      my $received = POST_BODY_ASSERT $location, content => $content;
      ok t_cmp($expected, $received, "STDIN tests");
  }
  
  {
      my $location = "$uri?STDOUT";
      my $expected = "life is hard and then you die! next you reincarnate...";
      my $received = GET_BODY_ASSERT $location;
      ok t_cmp($expected, $received, "STDOUT tests");
  }
  
  
  
  1.1                  modperl-2.0/t/response/TestModperl/request_rec_perlio_api.pm
  
  Index: request_rec_perlio_api.pm
  ===================================================================
  package TestModperl::request_rec_perlio_api;
  
  # this test is relevant only when the PerlIO STDIN/STDOUT are used (when
  # $Config{useperlio} is defined.)
  
  use strict;
  use warnings FATAL => 'all';
  
  use Apache::RequestIO ();
  use Apache::RequestRec ();
  
  use Apache::Test;
  use Apache::TestConfig;
  
  use File::Spec::Functions qw(catfile catdir);
  
  use Apache::Const -compile => 'OK';
  
  use Config;
  
  sub handler {
      my $r = shift;
  
      $r->args eq 'STDIN' ? test_STDIN($r) : test_STDOUT($r);
  
      return Apache::OK;
  }
  
  sub test_STDIN {
      my $r = shift;
  
      {
          # read the first 10 POST chars
          my $data;
          read STDIN, $data, 10;
          print STDOUT $data;
      }
  
     {
          # re-open STDIN to something else, and then see if we don't
          # lose any chars when we restore it to the POST stream
          open my $stdin, "<&STDIN" or die "Can't dup STDIN: $!";
  
          # at this occasion, let's test in memory files feature
          # (new in 5.8.0)
          my $in_mem_file = "<samba>";
          close STDIN;
          open STDIN, "<", \$in_mem_file
              or die "failed to open STDIN as 'in memory' file : $!";
          my $data;
          read STDIN, $data, length $in_mem_file;
          print STDOUT $data;
          close STDIN;
  
          open STDIN, "<&", $stdin or die "failed to restore STDIN: $!";
      }
  
      {
          # read the last 10 POST chars
          my $data;
          read STDIN, $data, 10;
          print STDOUT $data;
      }
  
  }
  
  sub test_STDOUT {
      my $r = shift;
  
      local $| = 0;
      print STDOUT "life is hard ";
  
      my $vars = Apache::Test::config()->{vars};
      my $target_dir = catdir $vars->{documentroot}, 'perlio';
      my $file = catfile $target_dir, "apache_stdout";
  
      # re-open STDOUT to something else, and then see if we can
      # continue printing to the client via STDOUT, after restoring it
      open my $stdout, ">&STDOUT" or die "Can't dup STDOUT: $!";
  
      # this should flush the above print to STDOUT
      open STDOUT, ">", $file or die "Can't open $file: $!";
      print STDOUT "and then ";
      close STDOUT;
  
      # flush things that went into the file as STDOUT
      open STDOUT, ">&", $stdout or die "failed to restore STDOUT: $!";
      open my $fh, $file or die "Can't open $file: $!";
      local $\;
      print <$fh>;
  
      # cleanup
      unlink $file;
  
      # close the dupped fh
      close $stdout;
  
      print "you die! ";
  
      # now close it completely and restore it, without using any dupped
      # filehandle
      close STDOUT;
      open STDOUT, ">:Apache", $r 
          or die "can't open STDOUT via :Apache layer : $!";
      print "next you reincarnate...";
  
  }
  
  1;
  __DATA__
  SetHandler perl-script