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, $_; - } -} [EMAIL PROTECTED] = (@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
