You are viewing a plain text version of this content. The canonical link for it is here.
Posted to modperl-cvs@perl.apache.org by st...@apache.org on 2004/11/29 23:10:05 UTC
svn commit: r106958 - in perl/modperl/trunk/t: conf filter/TestFilter lib/ModPerl lib/TestCommon response/TestAPI response/TestApache response/TestModperl
Author: stas
Date: Mon Nov 29 14:10:03 2004
New Revision: 106958
URL: http://svn.apache.org/viewcvs?view=rev&rev=106958
Log:
refactor modperl_extra.pl which was becoming a big mess
- move the code snippets into subs
- move helper modules into their own files under t/lib
Added:
perl/modperl/trunk/t/lib/ModPerl/
perl/modperl/trunk/t/lib/ModPerl/TestFilterDebug.pm
perl/modperl/trunk/t/lib/ModPerl/TestMemoryLeak.pm
perl/modperl/trunk/t/lib/ModPerl/TestTiePerlSection.pm
perl/modperl/trunk/t/lib/TestCommon/Handlers.pm
Modified:
perl/modperl/trunk/t/conf/extra.last.conf.in
perl/modperl/trunk/t/conf/modperl_extra.pl
perl/modperl/trunk/t/filter/TestFilter/both_str_native_remove.pm
perl/modperl/trunk/t/filter/TestFilter/both_str_req_add.pm
perl/modperl/trunk/t/filter/TestFilter/both_str_req_mix.pm
perl/modperl/trunk/t/filter/TestFilter/both_str_req_proxy.pm
perl/modperl/trunk/t/filter/TestFilter/in_autoload.pm
perl/modperl/trunk/t/filter/TestFilter/in_bbs_body.pm
perl/modperl/trunk/t/filter/TestFilter/in_bbs_consume.pm
perl/modperl/trunk/t/filter/TestFilter/in_bbs_inject_header.pm
perl/modperl/trunk/t/filter/TestFilter/in_bbs_underrun.pm
perl/modperl/trunk/t/filter/TestFilter/in_init_basic.pm
perl/modperl/trunk/t/filter/TestFilter/in_str_bin_data.pm
perl/modperl/trunk/t/filter/TestFilter/in_str_consume.pm
perl/modperl/trunk/t/filter/TestFilter/in_str_declined.pm
perl/modperl/trunk/t/filter/TestFilter/in_str_lc.pm
perl/modperl/trunk/t/filter/TestFilter/in_str_msg.pm
perl/modperl/trunk/t/filter/TestFilter/in_str_sandwich.pm
perl/modperl/trunk/t/filter/TestFilter/out_init_basic.pm
perl/modperl/trunk/t/filter/TestFilter/out_str_req_eos.pm
perl/modperl/trunk/t/filter/TestFilter/out_str_req_mix.pm
perl/modperl/trunk/t/filter/TestFilter/out_str_reverse.pm
perl/modperl/trunk/t/lib/TestCommon/Utils.pm
perl/modperl/trunk/t/response/TestAPI/content_encoding.pm
perl/modperl/trunk/t/response/TestApache/discard_rbody.pm
perl/modperl/trunk/t/response/TestApache/post.pm
perl/modperl/trunk/t/response/TestModperl/post_utf8.pm
Modified: perl/modperl/trunk/t/conf/extra.last.conf.in
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/conf/extra.last.conf.in?view=diff&rev=106958&p1=perl/modperl/trunk/t/conf/extra.last.conf.in&r1=106957&p2=perl/modperl/trunk/t/conf/extra.last.conf.in&r2=106958
==============================================================================
--- perl/modperl/trunk/t/conf/extra.last.conf.in (original)
+++ perl/modperl/trunk/t/conf/extra.last.conf.in Mon Nov 29 14:10:03 2004
@@ -14,6 +14,7 @@
<Perl >
#Test tied %Location
+use ModPerl::TestTiePerlSection ();
tie %Location, 'ModPerl::TestTiePerlSection';
$Location{'/tied'} = 'test_tied';
Modified: perl/modperl/trunk/t/conf/modperl_extra.pl
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/conf/modperl_extra.pl?view=diff&rev=106958&p1=perl/modperl/trunk/t/conf/modperl_extra.pl&r1=106957&p2=perl/modperl/trunk/t/conf/modperl_extra.pl&r2=106958
==============================================================================
--- perl/modperl/trunk/t/conf/modperl_extra.pl (original)
+++ perl/modperl/trunk/t/conf/modperl_extra.pl Mon Nov 29 14:10:03 2004
@@ -1,7 +1,7 @@
use strict;
use warnings FATAL => 'all';
-use Socket (); #test DynaLoader vs. XSLoader workaround for 5.6.x
+use Socket (); # test DynaLoader vs. XSLoader workaround for 5.6.x
use IO::File ();
use File::Spec::Functions qw(canonpath catdir);
@@ -10,56 +10,83 @@
use Apache::ServerRec ();
use Apache::ServerUtil ();
use Apache::Process ();
-
-# after Apache2 has pushed blib and core dirs including Apache2 on top
-# reorg @INC to have first devel libs, then blib libs, and only then
-# perl core libs
-my $pool = Apache->server->process->pool;
-my $project_root = canonpath
- Apache::ServerUtil::server_root_relative($pool, "..");
-my (@a, @b, @c);
-for (@INC) {
- if (m|^\Q$project_root\E|) {
- m|blib| ? push @b, $_ : push @a, $_;
- }
- else {
- push @c, $_;
- }
-}
-@INC = (@a, @b, @c);
-
-use ModPerl::Util (); #for CORE::GLOBAL::exit
-
use Apache::RequestRec ();
use Apache::RequestIO ();
use Apache::RequestUtil ();
-
use Apache::Connection ();
use Apache::Log ();
+use APR::Table ();
+
+use ModPerl::Util (); #for CORE::GLOBAL::exit
+
use Apache::Const -compile => ':common';
use APR::Const -compile => ':common';
-use APR::Table ();
+reorg_INC();
-unless ($ENV{MOD_PERL}) {
- die '$ENV{MOD_PERL} not set!';
+die '$ENV{MOD_PERL} not set!' unless $ENV{MOD_PERL};
+
+END {
+ warn "END in modperl_extra.pl, pid=$$\n";
}
-#see t/modperl/methodobj
-use TestModperl::methodobj ();
-$TestModperl::MethodObj = TestModperl::methodobj->new;
+startup_info();
+
+test_add_config();
+
+test_hooks_startup();
+
+test_method_obj();
+
+test_modperl_env();
+
+test_loglevel();
+
+test_add_version_component();
+
+test_apache_status();
+
+test_perl_ithreads();
+
-#see t/response/TestModperl/env.pm
-$ENV{MODPERL_EXTRA_PL} = __FILE__;
-my $ap_mods = scalar grep { /^Apache/ } keys %INC;
-my $apr_mods = scalar grep { /^APR/ } keys %INC;
+### only subs below this line ###
+
+sub reorg_INC {
+ # after Apache2 has pushed blib and core dirs including Apache2 on
+ # top reorg @INC to have first devel libs, then blib libs, and
+ # only then perl core libs
+ my $pool = Apache->server->process->pool;
+ my $project_root = canonpath
+ Apache::ServerUtil::server_root_relative($pool, "..");
+ my (@a, @b, @c);
+ for (@INC) {
+ if (m|^\Q$project_root\E|) {
+ m|blib| ? push @b, $_ : push @a, $_;
+ }
+ else {
+ push @c, $_;
+ }
+ }
+ @INC = (@a, @b, @c);
+}
+
+sub test_method_obj {
+ # see t/modperl/methodobj
+ use TestModperl::methodobj ();
+ $TestModperl::MethodObj = TestModperl::methodobj->new;
+}
+
+sub test_modperl_env {
+ # see t/response/TestModperl/env.pm
+ $ENV{MODPERL_EXTRA_PL} = __FILE__;
+}
# test startup loglevel setting (under threaded mpms loglevel can be
# changed only before threads are started) so here we test whether we
# can still set it after restart
-{
+sub test_loglevel {
use Apache::Const -compile => 'LOG_INFO';
my $s = Apache->server;
my $oldloglevel = $s->loglevel(Apache::LOG_INFO);
@@ -67,20 +94,26 @@
$s->loglevel($oldloglevel);
}
-Apache::Log->info("$ap_mods Apache:: modules loaded");
-Apache::ServerRec->log->info("$apr_mods APR:: modules loaded");
+sub startup_info {
+ my $ap_mods = scalar grep { /^Apache/ } keys %INC;
+ my $apr_mods = scalar grep { /^APR/ } keys %INC;
+
+ Apache::Log->info("$ap_mods Apache:: modules loaded");
+ Apache::ServerRec->log->info("$apr_mods APR:: modules loaded");
-{
my $server = Apache->server;
my $vhosts = 0;
for (my $s = $server->next; $s; $s = $s->next) {
$vhosts++;
}
+
$server->log->info("base server + $vhosts vhosts ready to run tests");
}
-# testing $s->add_config()
-my $conf = <<'EOC';
+
+sub test_add_config {
+ # testing $s->add_config()
+ my $conf = <<'EOC';
# must use PerlModule here to check for segfaults
PerlModule Apache::TestHandler
<Location /apache/add_config>
@@ -88,16 +121,17 @@
PerlResponseHandler Apache::TestHandler::ok1
</Location>
EOC
-Apache->server->add_config([split /\n/, $conf]);
+ Apache->server->add_config([split /\n/, $conf]);
-# test a directive that triggers an early startup, so we get an
-# attempt to use perl's mip early
-Apache->server->add_config(['<Perl >', '1;', '</Perl>']);
+ # test a directive that triggers an early startup, so we get an
+ # attempt to use perl's mip early
+ Apache->server->add_config(['<Perl >', '1;', '</Perl>']);
+}
# cleanup files for TestHooks::startup which can't be done from the
# test itself because the files are created at the server startup and
# the test needing these files may run more than once (t/SMOKE)
-{
+sub test_hooks_startup {
require Apache::Test;
my $dir = catdir Apache::Test::vars('documentroot'), qw(hooks startup);
for (<$dir/*>) {
@@ -106,8 +140,7 @@
}
}
-{
- # test add_version_component
+sub test_add_version_component {
Apache->server->push_handlers(
PerlPostConfigHandler => \&add_my_version);
@@ -118,96 +151,31 @@
}
}
-### Apache::Status tests
-use Apache::Status;
-use Apache::Module;
-Apache::Status->menu_item(
- 'test_menu' => "Test Menu Entry",
- sub {
- my($r, $q) = @_; #request and CGI objects
- return ["This is just a test entry"];
- }
-) if Apache::Module::loaded('Apache::Status');
-
-
-# this is needed for TestModperl::ithreads
-# one should be able to boot ithreads at the server startup and then
-# access the ithreads setup at run-time when a perl interpreter is
-# running on a different native threads (testing that perl
-# interpreters and ithreads aren't related to the native threads they
-# are running on). This should work starting from perl-5.8.1 and higher.
-use Config;
-if ($] >= 5.008001 && $Config{useithreads}) {
- eval { require threads; "threads"->import() };
-}
-
-use Apache::TestTrace;
-use Apache::Const -compile => qw(M_POST);
-
-# read the posted body and send it back to the client as is
-sub ModPerl::Test::pass_through_response_handler {
- my $r = shift;
-
- if ($r->method_number == Apache::M_POST) {
- my $data = ModPerl::Test::read_post($r);
- debug "pass_through_handler read: $data\n";
- $r->print($data);
+sub test_apache_status {
+ ### Apache::Status tests
+ require Apache::Status;
+ require Apache::Module;
+ Apache::Status->menu_item(
+ 'test_menu' => "Test Menu Entry",
+ sub {
+ my($r, $q) = @_; #request and CGI objects
+ return ["This is just a test entry"];
+ }
+ ) if Apache::Module::loaded('Apache::Status');
+}
+
+sub test_perl_ithreads {
+ # this is needed for TestPerl::ithreads
+ # one should be able to boot ithreads at the server startup and
+ # then access the ithreads setup at run-time when a perl
+ # interpreter is running on a different native threads (testing
+ # that perl interpreters and ithreads aren't related to the native
+ # threads they are running on). This should work starting from
+ # perl-5.8.1 and higher.
+ use Config;
+ if ($] >= 5.008001 && $Config{useithreads}) {
+ eval { require threads; "threads"->import() };
}
-
- Apache::OK;
-}
-
-use APR::Brigade ();
-use APR::Bucket ();
-use Apache::Filter ();
-
-use Apache::Const -compile => qw(MODE_READBYTES);
-use APR::Const -compile => qw(SUCCESS BLOCK_READ);
-
-use constant IOBUFSIZE => 8192;
-
-# to enable debug start with: (or simply run with -trace=debug)
-# t/TEST -trace=debug -start
-sub ModPerl::Test::read_post {
- my $r = shift;
- my $debug = shift || 0;
-
- my $bb = APR::Brigade->new($r->pool,
- $r->connection->bucket_alloc);
-
- my $data = '';
- my $seen_eos = 0;
- my $count = 0;
- do {
- $r->input_filters->get_brigade($bb, Apache::MODE_READBYTES,
- APR::BLOCK_READ, IOBUFSIZE);
-
- $count++;
-
- warn "read_post: bb $count\n" if $debug;
-
- while (!$bb->is_empty) {
- my $b = $bb->first;
-
- if ($b->is_eos) {
- warn "read_post: EOS bucket:\n" if $debug;
- $seen_eos++;
- last;
- }
-
- if ($b->read(my $buf)) {
- warn "read_post: DATA bucket: [$buf]\n" if $debug;
- $data .= $buf;
- }
-
- $b->delete;
- }
-
- } while (!$seen_eos);
-
- $bb->destroy;
-
- return $data;
}
sub ModPerl::Test::add_config {
@@ -226,191 +194,6 @@
Apache::OK;
-}
-
-END {
- warn "END in modperl_extra.pl, pid=$$\n";
-}
-
-package ModPerl::TestTiePerlSection;
-
-use strict;
-use warnings FATAL => 'all';
-
-# the following is needed for the tied %Location test in <Perl>
-# sections. Unfortunately it can't be defined in the section itself
-# due to the bug in perl:
-# http://rt.perl.org:80/rt3/Ticket/Display.html?id=29018
-
-use Tie::Hash;
-our @ISA = qw(Tie::StdHash);
-sub FETCH {
- my($hash, $key) = @_;
- if ($key eq '/tied') {
- return 'TIED';
- }
- return $hash->{$key};
-}
-
-package ModPerl::TestFilterDebug;
-
-use strict;
-use warnings FATAL => 'all';
-
-use base qw(Apache::Filter);
-use APR::Brigade ();
-use APR::Bucket ();
-use APR::BucketType ();
-
-use Apache::Const -compile => qw(OK DECLINED);
-use APR::Const -compile => ':common';
-
-# to use these functions add any or all of these filter handlers
-# PerlInputFilterHandler ModPerl::TestFilterDebug::snoop_request
-# PerlInputFilterHandler ModPerl::TestFilterDebug::snoop_connection
-# PerlOutputFilterHandler ModPerl::TestFilterDebug::snoop_request
-# PerlOutputFilterHandler ModPerl::TestFilterDebug::snoop_connection
-#
-
-sub snoop_connection : FilterConnectionHandler { snoop("connection", @_) }
-sub snoop_request : FilterRequestHandler { snoop("request", @_) }
-
-sub snoop {
- my $type = shift;
- my($filter, $bb, $mode, $block, $readbytes) = @_; # filter args
-
- # $mode, $block, $readbytes are passed only for input filters
- my $stream = defined $mode ? "input" : "output";
-
- # read the data and pass-through the bucket brigades unchanged
- if (defined $mode) {
- # input filter
- my $rv = $filter->next->get_brigade($bb, $mode, $block, $readbytes);
- return $rv unless $rv == APR::SUCCESS;
- bb_dump($type, $stream, $bb);
- }
- else {
- # output filter
- bb_dump($type, $stream, $bb);
- my $rv = $filter->next->pass_brigade($bb);
- return $rv unless $rv == APR::SUCCESS;
- }
- #if ($bb->is_empty) {
- # return -1;
- #}
-
- return Apache::OK;
-}
-
-sub bb_dump {
- my($type, $stream, $bb) = @_;
-
- my @data;
- for (my $b = $bb->first; $b; $b = $bb->next($b)) {
- $b->read(my $bdata);
- push @data, $b->type->name, $bdata;
- }
-
- # send the sniffed info to STDERR so not to interfere with normal
- # output
- my $direction = $stream eq 'output' ? ">>>" : "<<<";
- print STDERR "\n$direction $type $stream filter\n";
-
- unless (@data) {
- print STDERR " No buckets\n";
- return;
- }
-
- my $c = 1;
- while (my($btype, $data) = splice @data, 0, 2) {
- print STDERR " o bucket $c: $btype\n";
- print STDERR "[$data]\n";
- $c++;
- }
-}
-
-package ModPerl::TestMemoryLeak;
-
-# handy functions to measure memory leaks. since it measures the total
-# memory size of the process and not just perl leaks, you get your
-# C/XS leaks discovered too
-#
-# For example to test TestAPR::Pool::handler for leaks, add to its
-# top:
-#
-# ModPerl::TestMemoryLeak::start();
-#
-# and just before returning from the handler add:
-#
-# ModPerl::TestMemoryLeak::end();
-#
-# now start the server with only worker server
-#
-# % t/TEST -maxclients 1 -start
-#
-# of course use maxclients 1 only if your test be handled with one
-# client, e.g. proxy tests need at least two clients.
-#
-# Now repeat the same test several times (more than 3)
-#
-# % t/TEST -run apr/pool -times=10
-#
-# t/logs/error_log will include something like:
-#
-# size vsize resident share rss
-# 196k 132k 196k 0M 196k
-# 104k 132k 104k 0M 104k
-# 16k 0k 16k 0k 16k
-# 0k 0k 0k 0k 0k
-# 0k 0k 0k 0k 0k
-# 0k 0k 0k 0k 0k
-#
-# as you can see the first few runs were allocating memory, but the
-# following runs should consume no more memory. The leak tester measures
-# the extra memory allocated by the process since the last test. Notice
-# that perl and apr pools usually allocate more memory than they
-# need, so some leaks can be hard to see, unless many tests (like a
-# hundred) were run.
-
-use strict;
-use warnings FATAL => 'all';
-
-# XXX: as of 5.8.4 when spawning ithreads we get an annoying
-# Attempt to free unreferenced scalar ... perlbug #24660
-# because of $gtop's CLONE'd object, so pretend that we have no gtop
-# for now if perl is threaded
-# GTop v0.12 is the first version that will work under threaded mpms
-use Config;
-use constant HAS_GTOP => eval { !$Config{useithreads} &&
- require GTop && GTop->VERSION >= 0.12 };
-
-my $gtop = HAS_GTOP ? GTop->new : undef;
-my @attrs = qw(size vsize resident share rss);
-my $format = "%8s %8s %8s %8s %8s\n";
-
-my %before;
-
-sub start {
-
- die "No GTop avaible, bailing out" unless HAS_GTOP;
-
- unless (keys %before) {
- my $before = $gtop->proc_mem($$);
- %before = map { $_ => $before->$_() } @attrs;
- # print the header once
- warn sprintf $format, @attrs;
- }
-}
-
-sub end {
-
- die "No GTop avaible, bailing out" unless HAS_GTOP;
-
- my $after = $gtop->proc_mem($$);
- my %after = map {$_ => $after->$_()} @attrs;
- warn sprintf $format,
- map GTop::size_string($after{$_} - $before{$_}), @attrs;
- %before = %after;
}
1;
Modified: perl/modperl/trunk/t/filter/TestFilter/both_str_native_remove.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/filter/TestFilter/both_str_native_remove.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/filter/TestFilter/both_str_native_remove.pm&r1=106957&p2=perl/modperl/trunk/t/filter/TestFilter/both_str_native_remove.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/filter/TestFilter/both_str_native_remove.pm (original)
+++ perl/modperl/trunk/t/filter/TestFilter/both_str_native_remove.pm Mon Nov 29 14:10:03 2004
@@ -12,6 +12,8 @@
use Apache::Filter ();
use Apache::FilterRec ();
+use TestCommon::Utils ();
+
use Apache::Const -compile => qw(OK DECLINED);
# this filter removes the next filter in chain and itself
@@ -91,7 +93,7 @@
$r->content_type('text/plain');
if ($r->method_number == Apache::M_POST) {
- $r->print("content: " . ModPerl::Test::read_post($r) ."\n");
+ $r->print("content: " . TestCommon::Utils::read_post($r) ."\n");
}
my $i=1;
Modified: perl/modperl/trunk/t/filter/TestFilter/both_str_req_add.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/filter/TestFilter/both_str_req_add.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/filter/TestFilter/both_str_req_add.pm&r1=106957&p2=perl/modperl/trunk/t/filter/TestFilter/both_str_req_add.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/filter/TestFilter/both_str_req_add.pm (original)
+++ perl/modperl/trunk/t/filter/TestFilter/both_str_req_add.pm Mon Nov 29 14:10:03 2004
@@ -11,6 +11,8 @@
use Apache::Filter ();
+use TestCommon::Utils ();
+
use Apache::Const -compile => qw(OK M_POST);
sub header_parser {
@@ -62,7 +64,7 @@
$r->content_type('text/plain');
if ($r->method_number == Apache::M_POST) {
- $r->print(ModPerl::Test::read_post($r));
+ $r->print(TestCommon::Utils::read_post($r));
}
return Apache::OK;
Modified: perl/modperl/trunk/t/filter/TestFilter/both_str_req_mix.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/filter/TestFilter/both_str_req_mix.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/filter/TestFilter/both_str_req_mix.pm&r1=106957&p2=perl/modperl/trunk/t/filter/TestFilter/both_str_req_mix.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/filter/TestFilter/both_str_req_mix.pm (original)
+++ perl/modperl/trunk/t/filter/TestFilter/both_str_req_mix.pm Mon Nov 29 14:10:03 2004
@@ -70,6 +70,8 @@
use Apache::TestTrace;
+use TestCommon::Utils ();
+
use Apache::Const -compile => qw(OK M_POST);
use constant DEBUG => 1;
@@ -112,7 +114,7 @@
$r->content_type('text/plain');
if ($r->method_number == Apache::M_POST) {
- $r->print(ModPerl::Test::read_post($r));
+ $r->print(TestCommon::Utils::read_post($r));
}
return Apache::OK;
Modified: perl/modperl/trunk/t/filter/TestFilter/both_str_req_proxy.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/filter/TestFilter/both_str_req_proxy.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/filter/TestFilter/both_str_req_proxy.pm&r1=106957&p2=perl/modperl/trunk/t/filter/TestFilter/both_str_req_proxy.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/filter/TestFilter/both_str_req_proxy.pm (original)
+++ perl/modperl/trunk/t/filter/TestFilter/both_str_req_proxy.pm Mon Nov 29 14:10:03 2004
@@ -13,6 +13,8 @@
use Apache::TestTrace;
+use TestCommon::Utils ();
+
use Apache::Const -compile => qw(OK M_POST);
sub in_filter {
@@ -48,7 +50,7 @@
$r->content_type('text/plain');
if ($r->method_number == Apache::M_POST) {
- $r->print(ModPerl::Test::read_post($r));
+ $r->print(TestCommon::Utils::read_post($r));
}
return Apache::OK;
Modified: perl/modperl/trunk/t/filter/TestFilter/in_autoload.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/filter/TestFilter/in_autoload.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/filter/TestFilter/in_autoload.pm&r1=106957&p2=perl/modperl/trunk/t/filter/TestFilter/in_autoload.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/filter/TestFilter/in_autoload.pm (original)
+++ perl/modperl/trunk/t/filter/TestFilter/in_autoload.pm Mon Nov 29 14:10:03 2004
@@ -30,9 +30,10 @@
__DATA__
<NoAutoConfig>
+ PerlModule TestCommon::Handlers
<Location /TestFilter__in_autoload>
SetHandler modperl
- PerlResponseHandler ModPerl::Test::pass_through_response_handler
+ PerlResponseHandler TestCommon::Handlers::pass_through_response_handler
# no PerlModule TestFilter::in_load on purpose
PerlInputFilterHandler TestFilter::in_autoload
</Location>
Modified: perl/modperl/trunk/t/filter/TestFilter/in_bbs_body.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/filter/TestFilter/in_bbs_body.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/filter/TestFilter/in_bbs_body.pm&r1=106957&p2=perl/modperl/trunk/t/filter/TestFilter/in_bbs_body.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/filter/TestFilter/in_bbs_body.pm (original)
+++ perl/modperl/trunk/t/filter/TestFilter/in_bbs_body.pm Mon Nov 29 14:10:03 2004
@@ -10,6 +10,8 @@
use APR::Brigade ();
use APR::Bucket ();
+use TestCommon::Utils ();
+
use Apache::Const -compile => qw(OK M_POST);
use APR::Const -compile => ':common';
@@ -40,7 +42,7 @@
$r->content_type('text/plain');
if ($r->method_number == Apache::M_POST) {
- my $data = ModPerl::Test::read_post($r);
+ my $data = TestCommon::Utils::read_post($r);
$r->puts($data);
}
else {
Modified: perl/modperl/trunk/t/filter/TestFilter/in_bbs_consume.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/filter/TestFilter/in_bbs_consume.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/filter/TestFilter/in_bbs_consume.pm&r1=106957&p2=perl/modperl/trunk/t/filter/TestFilter/in_bbs_consume.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/filter/TestFilter/in_bbs_consume.pm (original)
+++ perl/modperl/trunk/t/filter/TestFilter/in_bbs_consume.pm Mon Nov 29 14:10:03 2004
@@ -14,6 +14,8 @@
use Apache::TestTrace;
+use TestCommon::Utils ();
+
use Apache::Const -compile => qw(OK M_POST);
use constant READ_SIZE => 26;
@@ -87,7 +89,7 @@
$r->content_type('text/plain');
if ($r->method_number == Apache::M_POST) {
- my $data = ModPerl::Test::read_post($r);
+ my $data = TestCommon::Utils::read_post($r);
#warn "HANDLER READ: $data\n";
$r->print($data);
}
Modified: perl/modperl/trunk/t/filter/TestFilter/in_bbs_inject_header.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/filter/TestFilter/in_bbs_inject_header.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/filter/TestFilter/in_bbs_inject_header.pm&r1=106957&p2=perl/modperl/trunk/t/filter/TestFilter/in_bbs_inject_header.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/filter/TestFilter/in_bbs_inject_header.pm (original)
+++ perl/modperl/trunk/t/filter/TestFilter/in_bbs_inject_header.pm Mon Nov 29 14:10:03 2004
@@ -38,6 +38,8 @@
use Apache::TestTrace;
+use TestCommon::Utils ();
+
use Apache::Const -compile => qw(OK DECLINED CONN_KEEPALIVE);
use APR::Const -compile => ':common';
@@ -237,7 +239,7 @@
$r->headers_out->set($key => $r->headers_in->get($key)||'');
}
- my $data = ModPerl::Test::read_post($r);
+ my $data = TestCommon::Utils::read_post($r);
$r->print($data);
Apache::OK;
Modified: perl/modperl/trunk/t/filter/TestFilter/in_bbs_underrun.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/filter/TestFilter/in_bbs_underrun.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/filter/TestFilter/in_bbs_underrun.pm&r1=106957&p2=perl/modperl/trunk/t/filter/TestFilter/in_bbs_underrun.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/filter/TestFilter/in_bbs_underrun.pm (original)
+++ perl/modperl/trunk/t/filter/TestFilter/in_bbs_underrun.pm Mon Nov 29 14:10:03 2004
@@ -49,6 +49,8 @@
use Apache::TestTrace;
+use TestCommon::Utils ();
+
use Apache::Const -compile => qw(OK M_POST);
use constant SIZE => 1024*16 + 5; # ~16k
@@ -134,7 +136,7 @@
$r->content_type('text/plain');
if ($r->method_number == Apache::M_POST) {
- my $data = ModPerl::Test::read_post($r);
+ my $data = TestCommon::Utils::read_post($r);
#warn "HANDLER READ: $data\n";
my $length = length $data;
$r->print("read $length chars");
Modified: perl/modperl/trunk/t/filter/TestFilter/in_init_basic.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/filter/TestFilter/in_init_basic.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/filter/TestFilter/in_init_basic.pm&r1=106957&p2=perl/modperl/trunk/t/filter/TestFilter/in_init_basic.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/filter/TestFilter/in_init_basic.pm (original)
+++ perl/modperl/trunk/t/filter/TestFilter/in_init_basic.pm Mon Nov 29 14:10:03 2004
@@ -11,11 +11,12 @@
use base qw(Apache::Filter);
+use TestCommon::Utils ();
+
use Apache::Const -compile => qw(OK M_POST);
use constant READ_SIZE => 1024;
-
# this filter is expected to be called once
# it'll set a note, with the count
sub transparent_init : FilterInitHandler {
@@ -61,7 +62,7 @@
$r->content_type('text/plain');
if ($r->method_number == Apache::M_POST) {
- $r->print(ModPerl::Test::read_post($r));
+ $r->print(TestCommon::Utils::read_post($r));
}
my @keys = qw(init run);
Modified: perl/modperl/trunk/t/filter/TestFilter/in_str_bin_data.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/filter/TestFilter/in_str_bin_data.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/filter/TestFilter/in_str_bin_data.pm&r1=106957&p2=perl/modperl/trunk/t/filter/TestFilter/in_str_bin_data.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/filter/TestFilter/in_str_bin_data.pm (original)
+++ perl/modperl/trunk/t/filter/TestFilter/in_str_bin_data.pm Mon Nov 29 14:10:03 2004
@@ -12,6 +12,8 @@
use Apache::TestTrace;
+use TestCommon::Utils ();
+
use Apache::Const -compile => qw(OK M_POST);
sub pass_through {
@@ -29,7 +31,7 @@
my $r = shift;
if ($r->method_number == Apache::M_POST) {
- my $data = ModPerl::Test::read_post($r);
+ my $data = TestCommon::Utils::read_post($r);
my $length = length $data;
debug "pass through $length bytes of $data\n";
$r->print($data);
Modified: perl/modperl/trunk/t/filter/TestFilter/in_str_consume.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/filter/TestFilter/in_str_consume.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/filter/TestFilter/in_str_consume.pm&r1=106957&p2=perl/modperl/trunk/t/filter/TestFilter/in_str_consume.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/filter/TestFilter/in_str_consume.pm (original)
+++ perl/modperl/trunk/t/filter/TestFilter/in_str_consume.pm Mon Nov 29 14:10:03 2004
@@ -60,6 +60,8 @@
use Apache::RequestRec ();
use Apache::RequestIO ();
+use TestCommon::Utils ();
+
use Apache::Const -compile => qw(OK M_POST);
use constant READ_BYTES_TOTAL => 105;
@@ -122,7 +124,7 @@
$r->content_type('text/plain');
if ($r->method_number == Apache::M_POST) {
- my $data = ModPerl::Test::read_post($r);
+ my $data = TestCommon::Utils::read_post($r);
# tell Apache to get rid of the rest of the request body
# if we don't a client will get a broken pipe and may fail to
Modified: perl/modperl/trunk/t/filter/TestFilter/in_str_declined.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/filter/TestFilter/in_str_declined.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/filter/TestFilter/in_str_declined.pm&r1=106957&p2=perl/modperl/trunk/t/filter/TestFilter/in_str_declined.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/filter/TestFilter/in_str_declined.pm (original)
+++ perl/modperl/trunk/t/filter/TestFilter/in_str_declined.pm Mon Nov 29 14:10:03 2004
@@ -11,6 +11,8 @@
use Apache::Filter ();
+use TestCommon::Utils ();
+
use Apache::Const -compile => qw(OK DECLINED M_POST);
# make sure that if the input filter returns DECLINED without
@@ -39,7 +41,7 @@
if ($r->method_number == Apache::M_POST) {
# consume the data so the input filter is invoked
- my $data = ModPerl::Test::read_post($r);
+ my $data = TestCommon::Utils::read_post($r);
ok t_cmp(length $data, 20000, "the request body received ok");
}
Modified: perl/modperl/trunk/t/filter/TestFilter/in_str_lc.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/filter/TestFilter/in_str_lc.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/filter/TestFilter/in_str_lc.pm&r1=106957&p2=perl/modperl/trunk/t/filter/TestFilter/in_str_lc.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/filter/TestFilter/in_str_lc.pm (original)
+++ perl/modperl/trunk/t/filter/TestFilter/in_str_lc.pm Mon Nov 29 14:10:03 2004
@@ -7,6 +7,8 @@
use Apache::RequestIO ();
use Apache::Filter ();
+use TestCommon::Utils ();
+
use Apache::Const -compile => qw(OK M_POST);
sub handler {
@@ -26,7 +28,7 @@
$r->content_type('text/plain');
if ($r->method_number == Apache::M_POST) {
- my $data = ModPerl::Test::read_post($r);
+ my $data = TestCommon::Utils::read_post($r);
#warn "HANDLER READ: $data\n";
$r->print($data);
}
Modified: perl/modperl/trunk/t/filter/TestFilter/in_str_msg.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/filter/TestFilter/in_str_msg.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/filter/TestFilter/in_str_msg.pm&r1=106957&p2=perl/modperl/trunk/t/filter/TestFilter/in_str_msg.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/filter/TestFilter/in_str_msg.pm (original)
+++ perl/modperl/trunk/t/filter/TestFilter/in_str_msg.pm Mon Nov 29 14:10:03 2004
@@ -22,6 +22,8 @@
use Apache::Test;
use Apache::TestUtil;
+use TestCommon::Utils ();
+
use Apache::Const -compile => 'OK';
use APR::Const -compile => ':common';
@@ -76,7 +78,7 @@
plan $r, tests => 1;
- my $received = ModPerl::Test::read_post($r);
+ my $received = TestCommon::Utils::read_post($r);
ok t_cmp($received, $expected,
"request filter must have upcased the data");
Modified: perl/modperl/trunk/t/filter/TestFilter/in_str_sandwich.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/filter/TestFilter/in_str_sandwich.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/filter/TestFilter/in_str_sandwich.pm&r1=106957&p2=perl/modperl/trunk/t/filter/TestFilter/in_str_sandwich.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/filter/TestFilter/in_str_sandwich.pm (original)
+++ perl/modperl/trunk/t/filter/TestFilter/in_str_sandwich.pm Mon Nov 29 14:10:03 2004
@@ -10,6 +10,8 @@
use Apache::RequestIO ();
use Apache::Filter ();
+use TestCommon::Utils ();
+
use Apache::Const -compile => qw(OK M_POST);
sub handler {
@@ -40,7 +42,7 @@
$r->content_type('text/plain');
if ($r->method_number == Apache::M_POST) {
- my $data = ModPerl::Test::read_post($r);
+ my $data = TestCommon::Utils::read_post($r);
#warn "HANDLER READ: $data\n";
$r->print($data);
}
Modified: perl/modperl/trunk/t/filter/TestFilter/out_init_basic.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/filter/TestFilter/out_init_basic.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/filter/TestFilter/out_init_basic.pm&r1=106957&p2=perl/modperl/trunk/t/filter/TestFilter/out_init_basic.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/filter/TestFilter/out_init_basic.pm (original)
+++ perl/modperl/trunk/t/filter/TestFilter/out_init_basic.pm Mon Nov 29 14:10:03 2004
@@ -11,6 +11,8 @@
use base qw(Apache::Filter);
+use TestCommon::Utils ();
+
use Apache::Const -compile => qw(OK M_POST);
use constant READ_SIZE => 1024;
@@ -66,7 +68,7 @@
my $data;
if ($r->method_number == Apache::M_POST) {
- $data = ModPerl::Test::read_post($r);
+ $data = TestCommon::Utils::read_post($r);
}
$r->print('init ', $r->notes->get('init'), "\n");
Modified: perl/modperl/trunk/t/filter/TestFilter/out_str_req_eos.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/filter/TestFilter/out_str_req_eos.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/filter/TestFilter/out_str_req_eos.pm&r1=106957&p2=perl/modperl/trunk/t/filter/TestFilter/out_str_req_eos.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/filter/TestFilter/out_str_req_eos.pm (original)
+++ perl/modperl/trunk/t/filter/TestFilter/out_str_req_eos.pm Mon Nov 29 14:10:03 2004
@@ -10,6 +10,8 @@
use Apache::RequestIO ();
use Apache::Filter ();
+use TestCommon::Utils ();
+
use Apache::Const -compile => qw(OK M_POST);
my $prefix = 'PREFIX_';
@@ -57,7 +59,7 @@
$r->content_type('text/plain');
if ($r->method_number == Apache::M_POST) {
- $r->print(ModPerl::Test::read_post($r));
+ $r->print(TestCommon::Utils::read_post($r));
}
return Apache::OK;
Modified: perl/modperl/trunk/t/filter/TestFilter/out_str_req_mix.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/filter/TestFilter/out_str_req_mix.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/filter/TestFilter/out_str_req_mix.pm&r1=106957&p2=perl/modperl/trunk/t/filter/TestFilter/out_str_req_mix.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/filter/TestFilter/out_str_req_mix.pm (original)
+++ perl/modperl/trunk/t/filter/TestFilter/out_str_req_mix.pm Mon Nov 29 14:10:03 2004
@@ -38,6 +38,8 @@
use Apache::Filter ();
+use TestCommon::Utils ();
+
use Apache::Const -compile => qw(OK M_POST);
sub adjust {
@@ -59,7 +61,7 @@
$r->content_type('text/plain');
if ($r->method_number == Apache::M_POST) {
- $r->print(ModPerl::Test::read_post($r));
+ $r->print(TestCommon::Utils::read_post($r));
}
return Apache::OK;
Modified: perl/modperl/trunk/t/filter/TestFilter/out_str_reverse.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/filter/TestFilter/out_str_reverse.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/filter/TestFilter/out_str_reverse.pm&r1=106957&p2=perl/modperl/trunk/t/filter/TestFilter/out_str_reverse.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/filter/TestFilter/out_str_reverse.pm (original)
+++ perl/modperl/trunk/t/filter/TestFilter/out_str_reverse.pm Mon Nov 29 14:10:03 2004
@@ -11,6 +11,8 @@
use Apache::RequestIO ();
use Apache::Filter ();
+use TestCommon::Utils ();
+
use Apache::Const -compile => qw(OK M_POST);
use constant BUFF_LEN => 2;
@@ -49,7 +51,7 @@
# unbuffer stdout, so we get the data split across several bbs
local $_ = 1;
if ($r->method_number == Apache::M_POST) {
- my $data = ModPerl::Test::read_post($r);
+ my $data = TestCommon::Utils::read_post($r);
$r->print($_) for grep length $_, split /(.{5})/, $data;
}
Added: perl/modperl/trunk/t/lib/ModPerl/TestFilterDebug.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/lib/ModPerl/TestFilterDebug.pm?view=auto&rev=106958
==============================================================================
--- (empty file)
+++ perl/modperl/trunk/t/lib/ModPerl/TestFilterDebug.pm Mon Nov 29 14:10:03 2004
@@ -0,0 +1,80 @@
+package ModPerl::TestFilterDebug;
+
+use strict;
+use warnings FATAL => 'all';
+
+use base qw(Apache::Filter);
+use APR::Brigade ();
+use APR::Bucket ();
+use APR::BucketType ();
+
+use Apache::Const -compile => qw(OK DECLINED);
+use APR::Const -compile => ':common';
+
+# to use these functions add any or all of these filter handlers
+# PerlInputFilterHandler ModPerl::TestFilterDebug::snoop_request
+# PerlInputFilterHandler ModPerl::TestFilterDebug::snoop_connection
+# PerlOutputFilterHandler ModPerl::TestFilterDebug::snoop_request
+# PerlOutputFilterHandler ModPerl::TestFilterDebug::snoop_connection
+#
+
+sub snoop_connection : FilterConnectionHandler { snoop("connection", @_) }
+sub snoop_request : FilterRequestHandler { snoop("request", @_) }
+
+sub snoop {
+ my $type = shift;
+ my($filter, $bb, $mode, $block, $readbytes) = @_; # filter args
+
+ # $mode, $block, $readbytes are passed only for input filters
+ my $stream = defined $mode ? "input" : "output";
+
+ # read the data and pass-through the bucket brigades unchanged
+ if (defined $mode) {
+ # input filter
+ my $rv = $filter->next->get_brigade($bb, $mode, $block, $readbytes);
+ return $rv unless $rv == APR::SUCCESS;
+ bb_dump($type, $stream, $bb);
+ }
+ else {
+ # output filter
+ bb_dump($type, $stream, $bb);
+ my $rv = $filter->next->pass_brigade($bb);
+ return $rv unless $rv == APR::SUCCESS;
+ }
+ #if ($bb->is_empty) {
+ # return -1;
+ #}
+
+ return Apache::OK;
+}
+
+sub bb_dump {
+ my($type, $stream, $bb) = @_;
+
+ my @data;
+ for (my $b = $bb->first; $b; $b = $bb->next($b)) {
+ $b->read(my $bdata);
+ push @data, $b->type->name, $bdata;
+ }
+
+ # send the sniffed info to STDERR so not to interfere with normal
+ # output
+ my $direction = $stream eq 'output' ? ">>>" : "<<<";
+ print STDERR "\n$direction $type $stream filter\n";
+
+ unless (@data) {
+ print STDERR " No buckets\n";
+ return;
+ }
+
+ my $c = 1;
+ while (my($btype, $data) = splice @data, 0, 2) {
+ print STDERR " o bucket $c: $btype\n";
+ print STDERR "[$data]\n";
+ $c++;
+ }
+}
+
+1;
+
+__END__
Added: perl/modperl/trunk/t/lib/ModPerl/TestMemoryLeak.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/lib/ModPerl/TestMemoryLeak.pm?view=auto&rev=106958
==============================================================================
--- (empty file)
+++ perl/modperl/trunk/t/lib/ModPerl/TestMemoryLeak.pm Mon Nov 29 14:10:03 2004
@@ -0,0 +1,87 @@
+package ModPerl::TestMemoryLeak;
+
+# handy functions to measure memory leaks. since it measures the total
+# memory size of the process and not just perl leaks, you get your
+# C/XS leaks discovered too
+#
+# For example to test TestAPR::Pool::handler for leaks, add to its
+# top:
+#
+# ModPerl::TestMemoryLeak::start();
+#
+# and just before returning from the handler add:
+#
+# ModPerl::TestMemoryLeak::end();
+#
+# now start the server with only worker server
+#
+# % t/TEST -maxclients 1 -start
+#
+# of course use maxclients 1 only if your test be handled with one
+# client, e.g. proxy tests need at least two clients.
+#
+# Now repeat the same test several times (more than 3)
+#
+# % t/TEST -run apr/pool -times=10
+#
+# t/logs/error_log will include something like:
+#
+# size vsize resident share rss
+# 196k 132k 196k 0M 196k
+# 104k 132k 104k 0M 104k
+# 16k 0k 16k 0k 16k
+# 0k 0k 0k 0k 0k
+# 0k 0k 0k 0k 0k
+# 0k 0k 0k 0k 0k
+#
+# as you can see the first few runs were allocating memory, but the
+# following runs should consume no more memory. The leak tester measures
+# the extra memory allocated by the process since the last test. Notice
+# that perl and apr pools usually allocate more memory than they
+# need, so some leaks can be hard to see, unless many tests (like a
+# hundred) were run.
+
+use strict;
+use warnings FATAL => 'all';
+
+# XXX: as of 5.8.4 when spawning ithreads we get an annoying
+# Attempt to free unreferenced scalar ... perlbug #24660
+# because of $gtop's CLONE'd object, so pretend that we have no gtop
+# for now if perl is threaded
+# GTop v0.12 is the first version that will work under threaded mpms
+use Config;
+use constant HAS_GTOP => eval { !$Config{useithreads} &&
+ require GTop && GTop->VERSION >= 0.12 };
+
+my $gtop = HAS_GTOP ? GTop->new : undef;
+my @attrs = qw(size vsize resident share rss);
+my $format = "%8s %8s %8s %8s %8s\n";
+
+my %before;
+
+sub start {
+
+ die "No GTop avaible, bailing out" unless HAS_GTOP;
+
+ unless (keys %before) {
+ my $before = $gtop->proc_mem($$);
+ %before = map { $_ => $before->$_() } @attrs;
+ # print the header once
+ warn sprintf $format, @attrs;
+ }
+}
+
+sub end {
+
+ die "No GTop avaible, bailing out" unless HAS_GTOP;
+
+ my $after = $gtop->proc_mem($$);
+ my %after = map {$_ => $after->$_()} @attrs;
+ warn sprintf $format,
+ map GTop::size_string($after{$_} - $before{$_}), @attrs;
+ %before = %after;
+}
+
+1;
+
+__END__
Added: perl/modperl/trunk/t/lib/ModPerl/TestTiePerlSection.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/lib/ModPerl/TestTiePerlSection.pm?view=auto&rev=106958
==============================================================================
--- (empty file)
+++ perl/modperl/trunk/t/lib/ModPerl/TestTiePerlSection.pm Mon Nov 29 14:10:03 2004
@@ -0,0 +1,21 @@
+package ModPerl::TestTiePerlSection;
+
+use strict;
+use warnings FATAL => 'all';
+
+# the following is needed for the tied %Location test in <Perl>
+# sections. Unfortunately it can't be defined in the section itself
+# due to the bug in perl:
+# http://rt.perl.org:80/rt3/Ticket/Display.html?id=29018
+
+use Tie::Hash;
+our @ISA = qw(Tie::StdHash);
+sub FETCH {
+ my($hash, $key) = @_;
+ if ($key eq '/tied') {
+ return 'TIED';
+ }
+ return $hash->{$key};
+}
+
+1;
Added: perl/modperl/trunk/t/lib/TestCommon/Handlers.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/lib/TestCommon/Handlers.pm?view=auto&rev=106958
==============================================================================
--- (empty file)
+++ perl/modperl/trunk/t/lib/TestCommon/Handlers.pm Mon Nov 29 14:10:03 2004
@@ -0,0 +1,61 @@
+package TestCommon::Handlers;
+
+use strict;
+use warnings FATAL => 'all';
+
+use Apache::RequestRec ();
+use Apache::RequestIO ();
+
+use TestCommon::Utils ();
+
+use Apache::TestTrace;
+
+use Apache::Const -compile => qw(M_POST OK);
+
+# read the posted body and send it back to the client as is
+sub pass_through_response_handler {
+ my $r = shift;
+
+ if ($r->method_number == Apache::M_POST) {
+ my $data = TestCommon::Utils::read_post($r);
+ debug "pass_through_handler read: $data\n";
+ $r->print($data);
+ }
+
+ Apache::OK;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+TestCommon::Handlers - Common Handlers
+
+
+
+=head1 Synopsis
+
+ # PerlModule TestCommon::Handlers
+ # PerlResponseHandler TestCommon::Handlers::pass_through_response_handler
+
+
+=head1 Description
+
+Various commonly used handlers
+
+
+
+
+=head1 API
+
+=head2 pass_through_response_handler
+
+ # PerlModule TestCommon::Handlers
+ # PerlResponseHandler TestCommon::Handlers::pass_through_response_handler
+
+this is a response handler, which reads the posted body and sends it
+back to the client as is.
+
+=cut
Modified: perl/modperl/trunk/t/lib/TestCommon/Utils.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/lib/TestCommon/Utils.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/lib/TestCommon/Utils.pm&r1=106957&p2=perl/modperl/trunk/t/lib/TestCommon/Utils.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/lib/TestCommon/Utils.pm (original)
+++ perl/modperl/trunk/t/lib/TestCommon/Utils.pm Mon Nov 29 14:10:03 2004
@@ -3,6 +3,15 @@
use strict;
use warnings FATAL => 'all';
+use APR::Brigade ();
+use APR::Bucket ();
+use Apache::Filter ();
+
+use Apache::Const -compile => qw(MODE_READBYTES);
+use APR::Const -compile => qw(SUCCESS BLOCK_READ);
+
+use constant IOBUFSIZE => 8192;
+
# perl 5.6.x only triggers taint protection on strings which are at
# least one char long
sub is_tainted {
@@ -13,6 +22,50 @@
};
}
+# to enable debug start with: (or simply run with -trace=debug)
+# t/TEST -trace=debug -start
+sub read_post {
+ my $r = shift;
+ my $debug = shift || 0;
+
+ my $bb = APR::Brigade->new($r->pool,
+ $r->connection->bucket_alloc);
+
+ my $data = '';
+ my $seen_eos = 0;
+ my $count = 0;
+ do {
+ $r->input_filters->get_brigade($bb, Apache::MODE_READBYTES,
+ APR::BLOCK_READ, IOBUFSIZE);
+
+ $count++;
+
+ warn "read_post: bb $count\n" if $debug;
+
+ while (!$bb->is_empty) {
+ my $b = $bb->first;
+
+ if ($b->is_eos) {
+ warn "read_post: EOS bucket:\n" if $debug;
+ $seen_eos++;
+ last;
+ }
+
+ if ($b->read(my $buf)) {
+ warn "read_post: DATA bucket: [$buf]\n" if $debug;
+ $data .= $buf;
+ }
+
+ $b->delete;
+ }
+
+ } while (!$seen_eos);
+
+ $bb->destroy;
+
+ return $data;
+}
+
1;
__END__
@@ -30,9 +83,8 @@
# test whether some SV is tainted
$b->read(my $data);
ok TestCommon::Utils::is_tainted($data);
-
-
-
+
+ my $data = TestCommon::Utils::read_post($r);
=head1 Description
@@ -45,7 +97,7 @@
-=head2 is_tainted()
+=head2 is_tainted
is_tainted(@data);
@@ -53,6 +105,15 @@
I<FALSE> otherwise.
+
+=head2 read_post
+
+ my $data = TestCommon::Utils::read_post($r);
+ my $data = TestCommon::Utils::read_post($r, $debug);
+
+reads the posted data using bucket brigades manipulation.
+
+To enable debug pass a true argument C<$debug>
=cut
Modified: perl/modperl/trunk/t/response/TestAPI/content_encoding.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/response/TestAPI/content_encoding.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/response/TestAPI/content_encoding.pm&r1=106957&p2=perl/modperl/trunk/t/response/TestAPI/content_encoding.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/response/TestAPI/content_encoding.pm (original)
+++ perl/modperl/trunk/t/response/TestAPI/content_encoding.pm Mon Nov 29 14:10:03 2004
@@ -8,6 +8,8 @@
use Apache::RequestRec ();
use Apache::RequestUtil ();
+use TestCommon::Utils ();
+
use Apache::Const -compile => qw(OK DECLINED);
sub handler {
@@ -15,7 +17,7 @@
return Apache::DECLINED unless $r->method_number == Apache::M_POST;
- my $data = ModPerl::Test::read_post($r);
+ my $data = TestCommon::Utils::read_post($r);
require Compress::Zlib;
Modified: perl/modperl/trunk/t/response/TestApache/discard_rbody.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/response/TestApache/discard_rbody.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/response/TestApache/discard_rbody.pm&r1=106957&p2=perl/modperl/trunk/t/response/TestApache/discard_rbody.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/response/TestApache/discard_rbody.pm (original)
+++ perl/modperl/trunk/t/response/TestApache/discard_rbody.pm Mon Nov 29 14:10:03 2004
@@ -13,6 +13,8 @@
use APR::Brigade ();
use APR::Error ();
+use TestCommon::Utils ();
+
use Apache::Const -compile => qw(OK MODE_READBYTES);
use APR::Const -compile => qw(SUCCESS BLOCK_READ);
@@ -38,7 +40,7 @@
}
elsif ($test eq 'all') {
# consume all of the request body
- my $data = ModPerl::Test::read_post($r);
+ my $data = TestCommon::Utils::read_post($r);
die "failed to consume all the data" unless length($data) == 100000;
}
Modified: perl/modperl/trunk/t/response/TestApache/post.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/response/TestApache/post.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/response/TestApache/post.pm&r1=106957&p2=perl/modperl/trunk/t/response/TestApache/post.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/response/TestApache/post.pm (original)
+++ perl/modperl/trunk/t/response/TestApache/post.pm Mon Nov 29 14:10:03 2004
@@ -6,13 +6,15 @@
use Apache::RequestRec ();
use Apache::RequestIO ();
+use TestCommon::Utils ();
+
use Apache::Const -compile => 'OK';
sub handler {
my $r = shift;
$r->content_type('text/plain');
- my $data = ModPerl::Test::read_post($r) || "";
+ my $data = TestCommon::Utils::read_post($r) || "";
$r->puts(join ':', length($data), $data);
Modified: perl/modperl/trunk/t/response/TestModperl/post_utf8.pm
Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/response/TestModperl/post_utf8.pm?view=diff&rev=106958&p1=perl/modperl/trunk/t/response/TestModperl/post_utf8.pm&r1=106957&p2=perl/modperl/trunk/t/response/TestModperl/post_utf8.pm&r2=106958
==============================================================================
--- perl/modperl/trunk/t/response/TestModperl/post_utf8.pm (original)
+++ perl/modperl/trunk/t/response/TestModperl/post_utf8.pm Mon Nov 29 14:10:03 2004
@@ -11,6 +11,8 @@
use Apache::RequestIO ();
use APR::Table ();
+use TestCommon::Utils ();
+
use Apache::Const -compile => 'OK';
my $expected_ascii = "I love you, (why lying?), but I belong to another";
@@ -33,7 +35,7 @@
plan $r, tests => 2,
need need_min_perl_version(5.008), need_perl('perlio');
- my $received = ModPerl::Test::read_post($r) || "";
+ my $received = TestCommon::Utils::read_post($r) || "";
# workaround for perl-5.8.0, which doesn't decode correctly a
# tainted variable