perl-modperl-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From s...@apache.org
Subject cvs commit: modperl-2.0/t/filter/TestFilter in_bbs_body.pm in_bbs_msg.pm out_bbs_basic.pm out_bbs_ctx.pm out_str_api.pm out_str_ctx.pm out_str_lc.pm out_str_reverse.pm in_str_msg.pm api.pm buckets.pm context.pm context_stream.pm input_body.pm input_msg.pm lc.pm reverse.pm
Date Wed, 15 Jan 2003 06:47:16 GMT
stas        2003/01/14 22:47:16

  Modified:    t/filter/TestFilter in_str_msg.pm
  Added:       t/filter in_bbs_body.t in_bbs_msg.t out_bbs_basic.t
                        out_bbs_ctx.t out_str_api.t out_str_ctx.t
                        out_str_lc.t out_str_reverse.t
               t/filter/TestFilter in_bbs_body.pm in_bbs_msg.pm
                        out_bbs_basic.pm out_bbs_ctx.pm out_str_api.pm
                        out_str_ctx.pm out_str_lc.pm out_str_reverse.pm
  Removed:     t/filter context.t context_stream.t input_body.t input_msg.t
                        lc.t reverse.t
               t/filter/TestFilter api.pm buckets.pm context.pm
                        context_stream.pm input_body.pm input_msg.pm lc.pm
                        reverse.pm
  Log:
  rename filter tests so it's easy to test what kind of filter is run from
  its name (also to tell the streaming interface from BBs.)
  
  Revision  Changes    Path
  1.1                  modperl-2.0/t/filter/in_bbs_body.t
  
  Index: in_bbs_body.t
  ===================================================================
  use strict;
  use warnings FATAL => 'all';
  
  use Apache::Test;
  use Apache::TestRequest;
  
  plan tests => 2;
  
  my $location = '/TestFilter::in_bbs_body';
  
  for my $x (1,2) {
      my $data = scalar reverse "ok $x\n";
      print POST_BODY $location, content => $data;
  }
  
  
  
  1.1                  modperl-2.0/t/filter/in_bbs_msg.t
  
  Index: in_bbs_msg.t
  ===================================================================
  use Apache::TestRequest;
  use Apache::Test ();
  use Apache::TestUtil;
  
  my $module = 'TestFilter::in_bbs_msg';
  
  Apache::TestRequest::scheme('http'); #force http for t/TEST -ssl
  Apache::TestRequest::module($module);
  
  my $config = Apache::Test::config();
  my $hostport = Apache::TestRequest::hostport($config);
  t_debug("connecting to $hostport");
  
  print GET_BODY("/input_filter.html");
  
  
  
  1.1                  modperl-2.0/t/filter/out_bbs_basic.t
  
  Index: out_bbs_basic.t
  ===================================================================
  # WARNING: this file is generated, do not edit
  # 01: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestConfig.pm:696
  # 02: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestConfig.pm:713
  # 03: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestConfigPerl.pm:83
  # 04: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestConfigPerl.pm:407
  # 05: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestConfig.pm:407
  # 06: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestConfig.pm:422
  # 07: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestConfig.pm:1215
  # 08: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestRun.pm:398
  # 09: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestRunPerl.pm:32
  # 10: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestRun.pm:569
  # 11: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestRun.pm:569
  # 12: t/TEST:19
  
  use Apache::TestRequest 'GET_BODY';
  print GET_BODY "/TestFilter::out_bbs_basic";
  
  
  
  1.1                  modperl-2.0/t/filter/out_bbs_ctx.t
  
  Index: out_bbs_ctx.t
  ===================================================================
  use strict;
  use warnings FATAL => 'all';
  
  use Apache::Test;
  use Apache::TestRequest;
  use Apache::TestUtil;
  
  plan tests => 1;
  
  my $blocks  = 33;
  my $invoked = 100;
  my $sig = join "\n", "received $blocks complete blocks",
      "filter invoked $invoked times\n";
  my $data = "#" x $blocks . "x" x $blocks;
  my $expected = join "\n", $data, $sig;
  
  {
      # test the filtering of the mod_perl response handler
      my $location = '/TestFilter::out_bbs_ctx';
      my $response = GET_BODY $location;
      ok t_cmp($expected, $response, "context filter");
  }
  
  
  
  1.1                  modperl-2.0/t/filter/out_str_api.t
  
  Index: out_str_api.t
  ===================================================================
  # WARNING: this file is generated, do not edit
  # 01: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestConfig.pm:696
  # 02: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestConfig.pm:713
  # 03: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestConfigPerl.pm:83
  # 04: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestConfigPerl.pm:407
  # 05: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestConfig.pm:407
  # 06: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestConfig.pm:422
  # 07: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestConfig.pm:1215
  # 08: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestRun.pm:398
  # 09: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestRunPerl.pm:32
  # 10: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestRun.pm:569
  # 11: /home/stas/apache.org/modperl-2.0/t/../Apache-Test/lib/Apache/TestRun.pm:569
  # 12: t/TEST:19
  
  use Apache::TestRequest 'GET_BODY';
  print GET_BODY "/TestFilter::out_str_api";
  
  
  
  1.1                  modperl-2.0/t/filter/out_str_ctx.t
  
  Index: out_str_ctx.t
  ===================================================================
  use strict;
  use warnings FATAL => 'all';
  
  use Apache::Test;
  use Apache::TestRequest;
  use Apache::TestUtil;
  
  plan tests => 1;
  
  my $blocks  = 33;
  my $invoked = 100;
  my $sig = join "\n", "received $blocks complete blocks",
      "filter invoked $invoked times\n";
  my $data = "#" x $blocks . "x" x $blocks;
  my $expected = join "\n", $data, $sig;
  
  {
      # test the filtering of the mod_perl response handler
      my $location = '/TestFilter::out_str_ctx';
      my $response = GET_BODY $location;
      ok t_cmp($expected, $response, "context stream filter");
  }
  
  
  
  1.1                  modperl-2.0/t/filter/out_str_lc.t
  
  Index: out_str_lc.t
  ===================================================================
  use strict;
  use warnings FATAL => 'all';
  
  use Apache::Test;
  use Apache::TestRequest;
  
  plan tests => 1;
  
  my $location = "/top_dir/Makefile";
  
  my $str = GET_BODY $location;
  
  ok $str !~ /[A-Z]/;
  
  
  
  1.1                  modperl-2.0/t/filter/out_str_reverse.t
  
  Index: out_str_reverse.t
  ===================================================================
  use strict;
  use warnings FATAL => 'all';
  
  use Apache::Test;
  use Apache::TestRequest;
  use Apache::TestUtil;
  
  plan tests => 2;
  
  my @data = (join('', 'a'..'z'), join('', 0..9));
  
  my $reversed_data = join '', map { scalar(reverse $_) . "\n" } @data;
  #t_debug($reversed_data);
  my $sig = "Reversed by mod_perl 2.0\n";
  my $expected = join "\n", @data, $sig;
  
  {
      # test the filtering of the mod_perl response handler
      my $location = '/TestFilter::out_str_reverse';
      my $response = POST_BODY $location, content => $reversed_data;
      ok t_cmp($expected, $response, "reverse filter");
  }
  
  {
      # test the filtering of the non-mod_perl response handler (file)
      my $location = '/filter/reverse.txt';
      my $response = GET_BODY $location;
      $response =~ s/\r//g;
      ok t_cmp($expected, $response, "reverse filter");
  }
  
  
  
  1.2       +2 -2      modperl-2.0/t/filter/TestFilter/in_str_msg.pm
  
  Index: in_str_msg.pm
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/t/filter/TestFilter/in_str_msg.pm,v
  retrieving revision 1.1
  retrieving revision 1.2
  diff -u -r1.1 -r1.2
  --- in_str_msg.pm	15 Jan 2003 06:19:25 -0000	1.1
  +++ in_str_msg.pm	15 Jan 2003 06:47:15 -0000	1.2
  @@ -18,11 +18,11 @@
   
   sub handler : FilterConnectionHandler {
       my($filter, $bb, $mode, $block, $readbytes) = @_;
  -    warn "FILTER CALLED\n";
  +    #warn "FILTER CALLED\n";
       my $ctx = $filter->ctx;
   
       while ($filter->read($mode, $block, $readbytes, my $buffer, 1024)) {
  -        warn "FILTER READ: $buffer\n";
  +        #warn "FILTER READ: $buffer\n";
           unless ($ctx) {
               $buffer =~ s|GET $from_url|GET $to_url|;
               $ctx = 1; # done
  
  
  
  1.1                  modperl-2.0/t/filter/TestFilter/in_bbs_body.pm
  
  Index: in_bbs_body.pm
  ===================================================================
  package TestFilter::in_bbs_body;
  
  use strict;
  use warnings FATAL => 'all';
  
  use base qw(Apache::Filter); #so we inherit MODIFY_CODE_ATTRIBUTES
  
  use Apache::RequestRec ();
  use Apache::RequestIO ();
  use APR::Brigade ();
  use APR::Bucket ();
  
  use Apache::Const -compile => qw(OK M_POST);
  use APR::Const -compile => ':common';
  
  sub handler : FilterRequestHandler {
      my($filter, $bb, $mode, $block, $readbytes) = @_;
  
      #warn "Called!";
      my $ba = $filter->r->connection->bucket_alloc;
  
      my $ctx_bb = APR::Brigade->new($filter->r->pool, $ba);
  
      my $rv = $filter->next->get_brigade($ctx_bb, $mode, $block, $readbytes);
  
      if ($rv != APR::SUCCESS) {
          return $rv;
      }
  
      while (!$ctx_bb->empty) {
          my $data;
          my $bucket = $ctx_bb->first;
  
          $bucket->remove;
  
          if ($bucket->is_eos) {
              #warn "EOS!!!!";
              $bb->insert_tail($bucket);
              last;
          }
  
          my $status = $bucket->read($data);
          #warn "DATA bucket!!!!";
          if ($status != APR::SUCCESS) {
              return $status;
          }
  
          if ($data) {
              #warn"[$data]\n";
              $bucket = APR::Bucket->new(scalar reverse $data);
          }
  
          $bb->insert_tail($bucket);
      }
  
      Apache::OK;
  }
  
  sub response {
      my $r = shift;
  
      $r->content_type('text/plain');
  
      if ($r->method_number == Apache::M_POST) {
          my $data = ModPerl::Test::read_post($r);
          $r->puts($data);
      }
      else {
          $r->puts("1..1\nok 1\n");
      }
  
      Apache::OK;
  }
  
  1;
  __DATA__
  SetHandler modperl
  PerlResponseHandler TestFilter::in_bbs_body::response
  
  
  
  1.1                  modperl-2.0/t/filter/TestFilter/in_bbs_msg.pm
  
  Index: in_bbs_msg.pm
  ===================================================================
  package TestFilter::in_bbs_msg;
  
  use strict;
  use warnings FATAL => 'all';
  
  use base qw(Apache::Filter);
  
  use Apache::RequestRec ();
  use Apache::RequestIO ();
  use APR::Brigade ();
  use APR::Bucket ();
  
  use Apache::Const -compile => 'OK';
  use APR::Const -compile => ':common';
  
  my $from_url = '/input_filter.html';
  my $to_url = '/TestFilter::in_bbs_msg::response';
  
  sub handler : FilterConnectionHandler {
      my($filter, $bb, $mode, $block, $readbytes) = @_;
  
      #warn "FILTER CALLED\n";
      my $c = $filter->c;
      my $ctx_bb = APR::Brigade->new($c->pool, $c->bucket_alloc);
  
      my $rv = $filter->next->get_brigade($ctx_bb, $mode, $block, $readbytes);
  
      if ($rv != APR::SUCCESS) {
          return $rv;
      }
  
      while (!$ctx_bb->empty) {
          my $data;
          my $bucket = $ctx_bb->first;
  
          $bucket->remove;
  
          if ($bucket->is_eos) {
              #warn "EOS!!!!";
              $bb->insert_tail($bucket);
              last;
          }
  
          my $status = $bucket->read($data);
          #warn "FILTER READ: $data\n";
  
          if ($status != APR::SUCCESS) {
              return $status;
          }
  
          if ($data and $data =~ s,GET $from_url,GET $to_url,) {
              $bucket = APR::Bucket->new($data);
          }
  
          $bb->insert_tail($bucket);
      }
  
      Apache::OK;
  }
  
  sub response {
      my $r = shift;
  
      $r->content_type('text/plain');
  
      $r->puts("1..1\nok 1\n");
  
      Apache::OK;
  }
  
  1;
  __END__
  <VirtualHost TestFilter::in_bbs_msg>
    # must be preloaded so the FilterConnectionHandler attributes will
    # be set by the time the filter is inserted into the filter chain
    PerlModule TestFilter::in_bbs_msg
    PerlInputFilterHandler TestFilter::in_bbs_msg
  
    <Location /TestFilter::in_bbs_msg::response>
       SetHandler modperl
       PerlResponseHandler TestFilter::in_bbs_msg::response
    </Location>
  
  </VirtualHost>
  
  
  
  1.1                  modperl-2.0/t/filter/TestFilter/out_bbs_basic.pm
  
  Index: out_bbs_basic.pm
  ===================================================================
  package TestFilter::out_bbs_basic;
  
  use strict;
  use warnings FATAL => 'all';
  
  use Apache::Test;
  
  use Apache::RequestRec ();
  use Apache::RequestIO ();
  use Apache::Filter ();
  use APR::Brigade ();
  use APR::Bucket ();
  
  use Apache::Const -compile => 'OK';
  
  #XXX: Not implemented yet, required by Test.pm
  sub Apache::TestToString::PRINTF {}
  
  sub handler {
      my($filter, $bb) = @_;
  
      unless ($filter->ctx) {
  
          Apache::TestToString->start;
  
          plan tests => 4;
  
          my $ba = $filter->r->connection->bucket_alloc;
  
          #should only have 1 bucket from the response() below
          for (my $bucket = $bb->first; $bucket; $bucket = $bb->next($bucket)) {
              ok $bucket->type->name;
              ok $bucket->length == 2;
              $bucket->read(my $data);
              ok (defined $data and $data eq 'ok');
          }
  
          my $tests = Apache::TestToString->finish;
  
          my $brigade = APR::Brigade->new($filter->r->pool, $ba);
          my $bucket = APR::Bucket->new($tests);
  
          $brigade->insert_tail($bucket);
  
          my $ok = $brigade->first->type->name =~ /mod_perl/ ? 4 : 0;
          $brigade->insert_tail(APR::Bucket->new("ok $ok\n"));
  
          $filter->next->pass_brigade($brigade);
  
          $filter->ctx(1); # flag that we have run this already
      }
  
      Apache::OK;
  }
  
  sub response {
      my $r = shift;
  
      $r->content_type('text/plain');
      $r->puts("ok");
  
      0;
  }
  
  1;
  __DATA__
  SetHandler modperl
  PerlResponseHandler TestFilter::out_bbs_basic::response
  
  
  
  1.1                  modperl-2.0/t/filter/TestFilter/out_bbs_ctx.pm
  
  Index: out_bbs_ctx.pm
  ===================================================================
  package TestFilter::out_bbs_ctx;
  
  # this is the same test as TestFilter::context_stream, but uses the
  # bucket brigade API
  
  use strict;
  use warnings;# FATAL => 'all';
  
  use Apache::RequestRec ();
  use Apache::RequestIO ();
  
  use APR::Brigade ();
  use APR::Bucket ();
  
  use base qw(Apache::Filter);
  
  use Apache::Const -compile => qw(OK M_POST);
  use APR::Const -compile => ':common';
  
  use constant BLOCK_SIZE => 5003;
  
  sub handler {
      my($filter, $bb) = @_;
  
      my $c = $filter->c;
      my $bb_ctx = APR::Brigade->new($c->pool, $c->bucket_alloc);
  
      my $ctx = $filter->ctx;
      $ctx->{invoked}++;
  
      my $data = exists $ctx->{data} ? $ctx->{data} : '';
  
      while (my $bucket = $bb->first) {
          $bucket->remove;
  
          if ($bucket->is_eos) {
              # flush the remainings and send a stats signature
              $bb_ctx->insert_tail(APR::Bucket->new("$data\n")) if $data;
              my $sig = join "\n", "received $ctx->{blocks} complete blocks",
                  "filter invoked $ctx->{invoked} times\n";
              $bb_ctx->insert_tail(APR::Bucket->new($sig));
              $bb_ctx->insert_tail($bucket);
              last;
          }
  
          my $status = $bucket->read(my $bdata);
          return $status unless $status == APR::SUCCESS;
  
          if (defined $bdata) {
              $data .= $bdata;
              my $len = length $data;
  
              my $blocks = 0;
              if ($len >= BLOCK_SIZE) {
                  $blocks = int($len / BLOCK_SIZE);
                  $len = $len % BLOCK_SIZE;
                  $data = substr $data, $blocks*BLOCK_SIZE, $len;
                  $ctx->{blocks} += $blocks;
              }
              if ($blocks) {
                  $bucket = APR::Bucket->new("#" x $blocks);
                  $bb_ctx->insert_tail($bucket);
              }
          }
      }
  
      $ctx->{data} = $data;
      $filter->ctx($ctx);
  
      my $rv = $filter->next->pass_brigade($bb_ctx);
      return $rv unless $rv == APR::SUCCESS;
  
      return Apache::OK;
  }
  
  sub response {
      my $r = shift;
  
      $r->content_type('text/plain');
  
      # make sure that 
      # - we send big enough data so it won't fit into one buffer
      # - use chunk size which doesn't nicely fit into a buffer size, so
      #   we have something to store in the context between filter calls
  
      my $blocks = 33;
      my $block_size = BLOCK_SIZE + 1;
      my $block = "x" x $block_size;
      for (1..$blocks) {
          $r->print($block);
          $r->rflush; # so the filter reads a chunk at a time
      }
  
      return Apache::OK;
  }
  
  1;
  __DATA__
  
  SetHandler modperl
  PerlResponseHandler TestFilter::out_bbs_ctx::response
  
  
  
  
  1.1                  modperl-2.0/t/filter/TestFilter/out_str_api.pm
  
  Index: out_str_api.pm
  ===================================================================
  package TestFilter::out_str_api;
  
  use strict;
  use warnings FATAL => 'all';
  
  use Apache::RequestRec ();
  use Apache::RequestIO ();
  use Apache::Filter ();
  use Apache::FilterRec ();
  
  use Apache::Test;
  
  use Apache::Const -compile => 'OK';
  
  my $response_data = "blah blah blah";
  
  #XXX: else pp_untie complains:
  #untie attempted while %d inner references still exist
  sub Apache::Filter::UNTIE {}
  sub Apache::Filter::PRINTF {}
  
  sub handler {
      my $filter = shift;
  
      unless ($filter->ctx) {
  
          $filter->read(my $buffer); #slurp everything;
  
          tie *STDOUT, $filter;
  
          plan tests => 6;
  
          ok $buffer eq $response_data;
  
          ok $filter->isa('Apache::Filter');
  
          my $frec = $filter->frec;
  
          ok $frec->isa('Apache::FilterRec');
  
          ok $frec->name;
  
          my $r = $filter->r;
  
          ok $r->isa('Apache::RequestRec');
  
          ok $r->uri eq '/' . __PACKAGE__;
  
          untie *STDOUT;
  
          $filter->ctx(1); # flag that we have sent this output already
  
      }
      Apache::OK;
  }
  
  sub response {
      my $r = shift;
  
      $r->content_type('text/plain');
      $r->puts($response_data);
  
      Apache::OK;
  }
  
  1;
  __DATA__
  SetHandler modperl
  PerlResponseHandler TestFilter::out_str_api::response
  
  
  
  1.1                  modperl-2.0/t/filter/TestFilter/out_str_ctx.pm
  
  Index: out_str_ctx.pm
  ===================================================================
  package TestFilter::out_str_ctx;
  
  # this is the same test as TestFilter::context, but uses the streaming
  # API
  
  use strict;
  use warnings;# FATAL => 'all';
  
  use Apache::RequestRec ();
  use Apache::RequestIO ();
  
  use APR::Brigade ();
  use APR::Bucket ();
  
  use base qw(Apache::Filter);
  
  use Apache::Const -compile => qw(OK M_POST);
  use APR::Const -compile => ':common';
  
  use constant BLOCK_SIZE => 5003;
  use constant READ_SIZE  => 1024;
  
  sub handler {
      my $filter = shift;
  
      my $ctx = $filter->ctx;
      my $data = exists $ctx->{data} ? $ctx->{data} : '';
      $ctx->{invoked}++;
  
      while ($filter->read(my $bdata, READ_SIZE)) {
          $data .= $bdata;
          my $len = length $data;
  
          my $blocks = 0;
          if ($len >= BLOCK_SIZE) {
              $blocks = int($len / BLOCK_SIZE);
              $len = $len % BLOCK_SIZE;
              $data = substr $data, $blocks*BLOCK_SIZE, $len;
              $ctx->{blocks} += $blocks;
          }
          if ($blocks) {
              $filter->print("#" x $blocks);
          }
      }
  
      if ($filter->seen_eos) {
          # flush the remaining data and add a statistics signature
          $filter->print("$data\n") if $data;
          my $sig = join "\n", "received $ctx->{blocks} complete blocks",
              "filter invoked $ctx->{invoked} times\n";
          $filter->print($sig);
      }
      else {
          # store context for all but the last invocation
          $ctx->{data} = $data;
          $filter->ctx($ctx);
      }
  
      return Apache::OK;
  }
  
  
  sub response {
      my $r = shift;
  
      $r->content_type('text/plain');
  
      # make sure that
      # - we send big enough data so it won't fit into one buffer
      # - use chunk size which doesn't nicely fit into a buffer size, so
      #   we have something to store in the context between filter calls
  
      my $blocks = 33;
      my $block_size = BLOCK_SIZE + 1;
      my $block = "x" x $block_size;
      for (1..$blocks) {
          $r->print($block);
          $r->rflush; # so the filter reads a chunk at a time
      }
  
      return Apache::OK;
  }
  
  1;
  __DATA__
  
  SetHandler modperl
  PerlResponseHandler TestFilter::out_str_ctx::response
  
  
  
  
  1.1                  modperl-2.0/t/filter/TestFilter/out_str_lc.pm
  
  Index: out_str_lc.pm
  ===================================================================
  package TestFilter::out_str_lc;
  
  use strict;
  use warnings FATAL => 'all';
  
  use Apache::Filter ();
  
  use Apache::Const -compile => 'OK';
  
  sub handler {
      my $filter = shift;
  
      while ($filter->read(my $buffer, 1024)) {
          $filter->print(lc $buffer);
      }
  
      Apache::OK;
  }
  
  1;
  __DATA__
  
  <Location /top_dir>
    PerlOutputFilterHandler TestFilter::out_str_lc
  </Location>
  
  Alias /top_dir @top_dir@
  
  
  
  1.1                  modperl-2.0/t/filter/TestFilter/out_str_reverse.pm
  
  Index: out_str_reverse.pm
  ===================================================================
  package TestFilter::out_str_reverse;
  
  use strict;
  use warnings FATAL => 'all';
  
  use Apache::RequestRec ();
  use Apache::RequestIO ();
  use Apache::Filter ();
  
  use Apache::Const -compile => qw(OK M_POST);
  
  sub handler {
      my $filter = shift;
  
      while ($filter->read(my $buffer, 1024)) {
          for (split "\n", $buffer) {
              $filter->print(scalar reverse $_);
              $filter->print("\n");
          }
      }
  
      if ($filter->seen_eos) {
          $filter->print("Reversed by mod_perl 2.0\n");
      }
  
      return Apache::OK;
  }
  
  sub response {
      my $r = shift;
  
      $r->content_type('text/plain');
  
      if ($r->method_number == Apache::M_POST) {
          my $data = ModPerl::Test::read_post($r);
          $r->puts($data);
      }
  
      return Apache::OK;
  }
  
  1;
  __DATA__
  <Base>
      <LocationMatch "/filter/reverse.txt">
          PerlOutputFilterHandler TestFilter::out_str_reverse
      </LocationMatch>
  </Base>
  
  SetHandler modperl
  PerlResponseHandler TestFilter::out_str_reverse::response
  
  
  
  

Mime
View raw message