Author: stas Date: Fri Dec 24 13:58:50 2004 New Revision: 123303 URL: http://svn.apache.org/viewcvs?view=rev&rev=123303 Log: deal with a situation where an object is used to construct another object, but it's then auto-DESTROYed by perl rendering the object that used it corrupted. the solution is to make the newly created objects refer to the underlying object via magic attachment. only objects using objects that have DESTROY are effected. This concerns some of the methods accepting the APR::Pool object. Adjusted: - APR::Brigade: new - APR::Finfo: stat - APR::IpSubnet: new - APR::Table: copy, overlay, make - APR::ThreadMutex: new
Modified: perl/modperl/trunk/Changes perl/modperl/trunk/src/modules/perl/modperl_common_util.c perl/modperl/trunk/t/lib/TestAPRlib/bucket.pm perl/modperl/trunk/t/lib/TestAPRlib/finfo.pm perl/modperl/trunk/t/lib/TestAPRlib/table.pm perl/modperl/trunk/t/lib/TestAPRlib/threadmutex.pm perl/modperl/trunk/t/response/TestAPR/brigade.pm perl/modperl/trunk/t/response/TestAPR/ipsubnet.pm perl/modperl/trunk/todo/release perl/modperl/trunk/xs/APR/Brigade/APR__Brigade.h perl/modperl/trunk/xs/APR/Bucket/APR__Bucket.h perl/modperl/trunk/xs/APR/Finfo/APR__Finfo.h perl/modperl/trunk/xs/APR/IpSubnet/APR__IpSubnet.h perl/modperl/trunk/xs/APR/Table/APR__Table.h perl/modperl/trunk/xs/APR/ThreadMutex/APR__ThreadMutex.h perl/modperl/trunk/xs/maps/apr_functions.map perl/modperl/trunk/xs/modperl_xs_util.h perl/modperl/trunk/xs/tables/current/ModPerl/FunctionTable.pm Modified: perl/modperl/trunk/Changes Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/Changes?view=diff&rev=123303&p1=perl/modperl/trunk/Changes&r1=123302&p2=perl/modperl/trunk/Changes&r2=123303 ============================================================================== --- perl/modperl/trunk/Changes (original) +++ perl/modperl/trunk/Changes Fri Dec 24 13:58:50 2004 @@ -12,6 +12,19 @@ =item 1.99_20-dev +deal with a situation where an object is used to construct another +object, but it's then auto-DESTROYed by perl rendering the object that +used it corrupted. the solution is to make the newly created objects +refer to the underlying object via magic attachment. only objects +using objects that have DESTROY are effected. This concerns some of +the methods accepting the APR::Pool object. [Stas] +Adjusted: +- APR::Brigade: new +- APR::Finfo: stat +- APR::IpSubnet: new +- APR::Table: copy, overlay, make +- APR::ThreadMutex: new + speed up the 'perl Makefile.PL' stage [Randy Kobes]: - reduce the number of calls to build_config() of Apache::Build within ModPerl::BuildMM Modified: perl/modperl/trunk/src/modules/perl/modperl_common_util.c Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/src/modules/perl/modperl_common_util.c?view=diff&rev=123303&p1=perl/modperl/trunk/src/modules/perl/modperl_common_util.c&r1=123302&p2=perl/modperl/trunk/src/modules/perl/modperl_common_util.c&r2=123303 ============================================================================== --- perl/modperl/trunk/src/modules/perl/modperl_common_util.c (original) +++ perl/modperl/trunk/src/modules/perl/modperl_common_util.c Fri Dec 24 13:58:50 2004 @@ -69,7 +69,7 @@ /* Prefetch magic requires perl 5.8 */ #if ((PERL_REVISION == 5) && (PERL_VERSION >= 8)) - sv_magic(hv, NULL, PERL_MAGIC_ext, Nullch, -1); + sv_magicext(hv, NULL, PERL_MAGIC_ext, NULL, Nullch, -1); SvMAGIC(hv)->mg_virtual = (MGVTBL *)&modperl_table_magic_prefetch; SvMAGIC(hv)->mg_flags |= MGf_COPY; Modified: perl/modperl/trunk/t/lib/TestAPRlib/bucket.pm Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/lib/TestAPRlib/bucket.pm?view=diff&rev=123303&p1=perl/modperl/trunk/t/lib/TestAPRlib/bucket.pm&r1=123302&p2=perl/modperl/trunk/t/lib/TestAPRlib/bucket.pm&r2=123303 ============================================================================== --- perl/modperl/trunk/t/lib/TestAPRlib/bucket.pm (original) +++ perl/modperl/trunk/t/lib/TestAPRlib/bucket.pm Fri Dec 24 13:58:50 2004 @@ -12,9 +12,10 @@ use APR::Pool (); use APR::Bucket (); use APR::BucketType (); +use APR::Table (); sub num_of_tests { - return 18; + return 23; } sub test { @@ -160,11 +161,49 @@ $data =~ s/^..../BBBB/; $b->read(my $read); ok !t_cmp($read, $data, - "data inside the setaside bucket is uaffected by " . + "data inside the setaside bucket is unaffected by " . "changes to the Perl variable it's created from"); $b->destroy; } + # alloc_create on out-of-scope pools + { + my $data = "foobartar"; + my $offset = 3; + my $real = substr $data, $offset; + my $ba = APR::Bucket::alloc_create(APR::Pool->new); + my $b = APR::Bucket->new($ba, $data, $offset); + + # try to overwrite the temp pool data + my $table = APR::Table::make(APR::Pool->new, 50); + $table->set($_ => $_) for 'aa'..'za'; + + # now test that we are still OK + my $rlen = $b->read(my $read); + ok t_cmp($read, $real, 'new($data, $offset)/buffer'); + ok t_cmp($rlen, length($read), 'new($data, $offset)/len'); + ok t_cmp($b->start, $offset, 'offset'); + + } + + # setaside on out-of-scope pools + { + my $data = "A" x 10; + my $orig = $data; + my $b = APR::Bucket->new($ba, $data); + my $status = $b->setaside(APR::Pool->new); + ok t_cmp $status, 0, "setaside status"; + + # try to overwrite the temp pool data + my $table = APR::Table::make(APR::Pool->new, 50); + $table->set($_ => $_) for 'aa'..'za'; + + # now test that we are still OK + $b->read(my $read); + ok t_cmp($read, $data, + "data inside the setaside bucket is not corrupted"); + $b->destroy; + } APR::Bucket::alloc_destroy($ba); Modified: perl/modperl/trunk/t/lib/TestAPRlib/finfo.pm Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/lib/TestAPRlib/finfo.pm?view=diff&rev=123303&p1=perl/modperl/trunk/t/lib/TestAPRlib/finfo.pm&r1=123302&p2=perl/modperl/trunk/t/lib/TestAPRlib/finfo.pm&r2=123303 ============================================================================== --- perl/modperl/trunk/t/lib/TestAPRlib/finfo.pm (original) +++ perl/modperl/trunk/t/lib/TestAPRlib/finfo.pm Fri Dec 24 13:58:50 2004 @@ -24,7 +24,7 @@ FPROT_WEXECUTE); sub num_of_tests { - return 15; + return 27; } sub test { @@ -44,40 +44,79 @@ ok $finfo->isa('APR::Finfo'); - # stat tests (same as perl's stat) - { - # now, get information from perl's stat() - our($device, $inode, $protection, $nlink, $user, $group, - undef, $size, $atime, $mtime, $ctime) = stat $file; + # now, get information from perl's stat() + my %stat; - # skip certain tests on Win32 and others - my %skip = (); + @stat{qw(device inode protection nlink user group size atime mtime + ctime)} = (stat $file)[0..5, 7..10]; - if (WIN32) { - # atime is wrong on NTFS, but OK on FAT32 - %skip = map {$_ => 1} qw(device inode user group atime); + compare_with_perl($finfo, \%stat); + + # tests for stuff not in perl's stat + { + # BACK_COMPAT_MARKER - fixed as of 2.0.49. + if (WIN32 && !APACHE_2_0_49_PLUS) { + skip "finfo.fname requires Apache 2.0.49 or later", 0; } - elsif (OSX) { - # XXX both apr and perl report incorrect group values. sometimes. - # XXX skip until we can really figure out what is going on. - %skip = (group => 1); + else { + ok t_cmp($finfo->fname, + $file, + '$finfo->fname()'); } - # compare stat fields between perl and apr_stat - { - no strict qw(refs); - foreach my $method (qw(device inode nlink user group - size atime mtime ctime)) { - if ($skip{$method}) { - skip "different file semantics", 0; - } - else { - ok t_cmp($finfo->$method(), - ${$method}, - "\$finfo->$method()"); - } + ok t_cmp($finfo->filetype, + APR::FILETYPE_REG, + '$finfo->filetype()'); + } + + # stat() on out-of-scope pools + { + my $finfo = APR::Finfo::stat($file, APR::FINFO_NORM, APR::Pool->new); + + # try to overwrite the temp pool data + require APR::Table; + my $table = APR::Table::make(APR::Pool->new, 50); + $table->set($_ => $_) for 'aa'..'za'; + + # now test that we are still OK + compare_with_perl($finfo, \%stat); + } + +} + + +sub compare_with_perl { + my ($finfo, $stat) = @_; + # skip certain tests on Win32 and others + my %skip = (); + + if (WIN32) { + # atime is wrong on NTFS, but OK on FAT32 + %skip = map {$_ => 1} qw(device inode user group atime); + } + elsif (OSX) { + # XXX both apr and perl report incorrect group values. sometimes. + # XXX skip until we can really figure out what is going on. + %skip = (group => 1); + } + + # compare stat fields between perl and apr_stat + { + foreach my $method (qw(device inode nlink user group + size atime mtime ctime)) { + if ($skip{$method}) { + skip "different file semantics", 0; + } + else { + ok t_cmp($finfo->$method(), + $stat->{$method}, + "\$finfo->$method()"); } } + } + + # stat tests (same as perl's stat) + { # XXX: untested # ->name @@ -88,8 +127,8 @@ # if (my $csize = $finfo->csize) { # # The storage size is at least as big as the file size # # perl's stat() doesn't have the equivalent of csize - # t_debug "csize=$csize, size=$size"; - # ok $csize >= $size; + # t_debug "csize=$csize, size=$stat{size}"; + # ok $csize >= $stat{size}; # } # else { # skip "csize is not available on this platform", 0; @@ -98,11 +137,11 @@ # match world bits ok t_cmp($finfo->protection & APR::FPROT_WREAD, - $protection & S_IROTH, + $stat->{protection} & S_IROTH, '$finfo->protection() & APR::FPROT_WREAD'); ok t_cmp($finfo->protection & APR::FPROT_WWRITE, - $protection & S_IWOTH, + $stat->{protection} & S_IWOTH, '$finfo->protection() & APR::FPROT_WWRITE'); if (WIN32) { @@ -110,26 +149,9 @@ } else { ok t_cmp($finfo->protection & APR::FPROT_WEXECUTE, - $protection & S_IXOTH, + $stat->{protection} & S_IXOTH, '$finfo->protection() & APR::FPROT_WEXECUTE'); } - } - - # tests for stuff not in perl's stat - { - # BACK_COMPAT_MARKER - fixed as of 2.0.49. - if (WIN32 && !APACHE_2_0_49_PLUS) { - skip "finfo.fname requires Apache 2.0.49 or later", 0; - } - else { - ok t_cmp($finfo->fname, - $file, - '$finfo->fname()'); - } - - ok t_cmp($finfo->filetype, - APR::FILETYPE_REG, - '$finfo->filetype()'); } } Modified: perl/modperl/trunk/t/lib/TestAPRlib/table.pm Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/lib/TestAPRlib/table.pm?view=diff&rev=123303&p1=perl/modperl/trunk/t/lib/TestAPRlib/table.pm&r1=123302&p2=perl/modperl/trunk/t/lib/TestAPRlib/table.pm&r2=123303 ============================================================================== --- perl/modperl/trunk/t/lib/TestAPRlib/table.pm (original) +++ perl/modperl/trunk/t/lib/TestAPRlib/table.pm Fri Dec 24 13:58:50 2004 @@ -17,7 +17,7 @@ our $filter_count; sub num_of_tests { - my $tests = 50; + my $tests = 56; # tied hash values() for a table w/ multiple values for the same # key @@ -295,6 +295,59 @@ ok t_cmp($foo[0], 'one, two, three'); ok t_cmp($bar[0], 'beer'); } + + + # temp pool objects. + # testing here that the temp pool object doesn't go out of scope + # before the object based on it was freed. the following tests + # were previously segfaulting when using apr1/httpd2.1 built w/ + # --enable-pool-debug CPPFLAGS="-DAPR_BUCKET_DEBUG", + # the affected methods are: + # - make + # - copy + # - overlay + { + my $table = APR::Table::make(APR::Pool->new, 10); + $table->set($_ => $_) for 1..20; + ok t_cmp $table->get(20), 20, "no segfault"; + + my $table_copy = $table->copy(APR::Pool->new); + { + # verify that the temp pool used to create $table_copy was + # not freed, by allocating a new table to fill with a + # different data. if that former pool was freed + # $table_copy will now contain bogus data (and may + # segfault) + my $table = APR::Table::make(APR::Pool->new, 50); + $table->set($_ => $_) for 'a'..'z'; + ok t_cmp $table->get('z'), 'z', "helper test"; + + } + ok t_cmp $table_copy->get(20), 20, "no segfault/valid data"; + + my $table2 = APR::Table::make(APR::Pool->new, 1); + $table2->set($_**2 => $_**2) for 1..20; + my $overlay = $table_copy->overlay($table2, APR::Pool->new); + { + # see the comment for above's: + # $table_copy = $table->copy(APR::Pool->new); + my $table = APR::Table::make(APR::Pool->new, 50); + $table->set($_ => $_) for 'aa'..'za'; + ok t_cmp $table->get('za'), 'za', "helper test"; + + } + ok t_cmp $overlay->get(20), 20, "no segfault/valid data"; + } + { + { + my $p = APR::Pool->new; + $p->cleanup_register(sub { "whatever" }); + $table = APR::Table::make($p, 10) + }; + $table->set(a => 5); + ok t_cmp $table->get("a"), 5, "no segfault"; + } + } sub my_filter { Modified: perl/modperl/trunk/t/lib/TestAPRlib/threadmutex.pm Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/lib/TestAPRlib/threadmutex.pm?view=diff&rev=123303&p1=perl/modperl/trunk/t/lib/TestAPRlib/threadmutex.pm&r1=123302&p2=perl/modperl/trunk/t/lib/TestAPRlib/threadmutex.pm&r2=123303 ============================================================================== --- perl/modperl/trunk/t/lib/TestAPRlib/threadmutex.pm (original) +++ perl/modperl/trunk/t/lib/TestAPRlib/threadmutex.pm Fri Dec 24 13:58:50 2004 @@ -10,7 +10,7 @@ use APR::Pool(); sub num_of_tests { - return 3; + return 5; } sub test { @@ -32,6 +32,20 @@ ok t_cmp($mutex->unlock, APR::SUCCESS, 'unlock == APR::SUCCESS'); + + # out-of-scope pool + { + my $mutex = APR::ThreadMutex->new(APR::Pool->new); + # try to overwrite the temp pool data + require APR::Table; + my $table = APR::Table::make(APR::Pool->new, 50); + $table->set($_ => $_) for 'aa'..'za'; + # now test that we are still OK + ok t_cmp($mutex->lock, APR::SUCCESS, + 'lock == APR::SUCCESS'); + ok t_cmp($mutex->unlock, APR::SUCCESS, + 'unlock == APR::SUCCESS'); + } } Modified: perl/modperl/trunk/t/response/TestAPR/brigade.pm Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/response/TestAPR/brigade.pm?view=diff&rev=123303&p1=perl/modperl/trunk/t/response/TestAPR/brigade.pm&r1=123302&p2=perl/modperl/trunk/t/response/TestAPR/brigade.pm&r2=123303 ============================================================================== --- perl/modperl/trunk/t/response/TestAPR/brigade.pm (original) +++ perl/modperl/trunk/t/response/TestAPR/brigade.pm Fri Dec 24 13:58:50 2004 @@ -20,7 +20,8 @@ my $r = shift; my $ba = $r->connection->bucket_alloc; - plan $r, tests => 13; + + plan $r, tests => 14; # basic + pool + destroy { @@ -77,6 +78,22 @@ $len = $bb3->flatten($data); ok t_cmp($len, 6, "bb3 flatten/len"); ok t_cmp($data, "122122", "bb3 flatten/data"); + } + + # out-of-scope pools + { + my $bb1 = APR::Brigade->new(APR::Pool->new, $ba); + $bb1->insert_head(APR::Bucket->new($ba, "11")); + $bb1->insert_tail(APR::Bucket->new($ba, "12")); + + # try to overwrite the temp pool data + require APR::Table; + my $table = APR::Table::make(APR::Pool->new, 50); + $table->set($_ => $_) for 'aa'..'za'; + # now test that we are still OK + + my $len = $bb1->flatten(my $data); + ok t_cmp($data, "1112", "correct data"); } Apache::OK; Modified: perl/modperl/trunk/t/response/TestAPR/ipsubnet.pm Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/t/response/TestAPR/ipsubnet.pm?view=diff&rev=123303&p1=perl/modperl/trunk/t/response/TestAPR/ipsubnet.pm&r1=123302&p2=perl/modperl/trunk/t/response/TestAPR/ipsubnet.pm&r2=123303 ============================================================================== --- perl/modperl/trunk/t/response/TestAPR/ipsubnet.pm (original) +++ perl/modperl/trunk/t/response/TestAPR/ipsubnet.pm Fri Dec 24 13:58:50 2004 @@ -8,7 +8,7 @@ use Apache::Connection (); use Apache::RequestRec (); - +use APR::Pool (); use APR::IpSubnet (); use APR::SockAddr (); @@ -19,7 +19,7 @@ my $c = $r->connection; my $p = $r->pool; - plan $r, tests => 7; + plan $r, tests => 8; my $ip = $c->remote_ip; @@ -67,6 +67,17 @@ { my $ipsub = eval { APR::IpSubnet->new($p, $ip, "255.0") }; ok t_cmp($@, qr/The specified network mask is invalid/, "bogus mask"); + } + + # temp pool + { + my $ipsub = APR::IpSubnet->new(APR::Pool->new, $ip); + # try to overwrite the temp pool data + require APR::Table; + my $table = APR::Table::make(APR::Pool->new, 50); + $table->set($_ => $_) for 'aa'..'za'; + # now test that we are still OK + ok $ipsub->test($c->remote_addr); } Apache::OK; Modified: perl/modperl/trunk/todo/release Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/todo/release?view=diff&rev=123303&p1=perl/modperl/trunk/todo/release&r1=123302&p2=perl/modperl/trunk/todo/release&r2=123303 ============================================================================== --- perl/modperl/trunk/todo/release (original) +++ perl/modperl/trunk/todo/release Fri Dec 24 13:58:50 2004 @@ -48,34 +48,21 @@ === APR::Pool === ================= *** returning objects *** - - APR::Brigade: - - mpxs_apr_brigade_create - + APR::Bucket: - - apr_bucket_alloc_create - - mpxs_APR__Bucket_setaside - - APR::Finfo: - - mpxs_APR__Finfo_stat - - APR::IpSubnet: - - mpxs_apr_ipsubnet_create + V apr_bucket_alloc_create + ? mpxs_APR__Bucket_setaside + (the wrapper is done, but the test is not reproducing the + problem, but this seems to be a problem in + modperl_bucket_sv_setaside which loses the newly seta-aside + bucket) APR::Pool: - - mpxs_apr_pool_create (not sure about this one) + ? mpxs_apr_pool_create (having problems): APR__Pool.patch Apache::RequestUtil: - - mpxs_Apache__RequestRec_new - - APR::Table: - - apr_table_copy - - apr_table_overlay - - apr_table_make + ? mpxs_Apache__RequestRec_new (having problems): Apache__RequestUtil.patch - APR::ThreadMutex - - mpxs_apr_thread_mutex_create - *** returning strings *** Apache::ServerUtil Modified: perl/modperl/trunk/xs/APR/Brigade/APR__Brigade.h Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/xs/APR/Brigade/APR__Brigade.h?view=diff&rev=123303&p1=perl/modperl/trunk/xs/APR/Brigade/APR__Brigade.h&r1=123302&p2=perl/modperl/trunk/xs/APR/Brigade/APR__Brigade.h&r2=123303 ============================================================================== --- perl/modperl/trunk/xs/APR/Brigade/APR__Brigade.h (original) +++ perl/modperl/trunk/xs/APR/Brigade/APR__Brigade.h Fri Dec 24 13:58:50 2004 @@ -22,11 +22,14 @@ } static MP_INLINE -apr_bucket_brigade *mpxs_apr_brigade_create(pTHX_ SV *CLASS, - apr_pool_t *p, - apr_bucket_alloc_t *ba) +SV *mpxs_apr_brigade_create(pTHX_ SV *CLASS, SV *p_sv, + apr_bucket_alloc_t *ba) { - return apr_brigade_create(p, ba); + apr_pool_t *p = mp_xs_sv2_APR__Pool(p_sv); + apr_bucket_brigade *bb = apr_brigade_create(p, ba); + SV *bb_sv = sv_setref_pv(NEWSV(0, 0), "APR::Brigade", (void*)bb); + mpxs_add_pool_magic(bb_sv, p_sv); + return bb_sv; } #define get_brigade(brigade, fetch) \ Modified: perl/modperl/trunk/xs/APR/Bucket/APR__Bucket.h Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/xs/APR/Bucket/APR__Bucket.h?view=diff&rev=123303&p1=perl/modperl/trunk/xs/APR/Bucket/APR__Bucket.h&r1=123302&p2=perl/modperl/trunk/xs/APR/Bucket/APR__Bucket.h&r2=123303 ============================================================================== --- perl/modperl/trunk/xs/APR/Bucket/APR__Bucket.h (original) +++ perl/modperl/trunk/xs/APR/Bucket/APR__Bucket.h Fri Dec 24 13:58:50 2004 @@ -101,14 +101,29 @@ } static MP_INLINE -apr_status_t mpxs_APR__Bucket_setaside(pTHX_ apr_bucket *b, apr_pool_t *p) +apr_status_t mpxs_APR__Bucket_setaside(pTHX_ SV *b_sv, SV *p_sv) { + apr_pool_t *p = mp_xs_sv2_APR__Pool(p_sv); + apr_bucket *b = mp_xs_sv2_APR__Bucket(b_sv); apr_status_t rc = apr_bucket_setaside(b, p); + /* if users don't bother to check the success, do it on their * behalf */ if (GIMME_V == G_VOID && rc != APR_SUCCESS) { modperl_croak(aTHX_ rc, "APR::Bucket::setaside"); } - + + //mpxs_add_pool_magic(b_sv, p_sv); + return rc; +} + +static MP_INLINE +SV *mpxs_APR__Bucket_alloc_create(pTHX_ SV *p_sv) +{ + apr_pool_t *p = mp_xs_sv2_APR__Pool(p_sv); + apr_bucket_alloc_t *ba = apr_bucket_alloc_create(p); + SV *ba_sv = sv_setref_pv(NEWSV(0, 0), "APR::BucketAlloc", (void*)ba); + //mpxs_add_pool_magic(ba_sv, p_sv); + return ba_sv; } Modified: perl/modperl/trunk/xs/APR/Finfo/APR__Finfo.h Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/xs/APR/Finfo/APR__Finfo.h?view=diff&rev=123303&p1=perl/modperl/trunk/xs/APR/Finfo/APR__Finfo.h&r1=123302&p2=perl/modperl/trunk/xs/APR/Finfo/APR__Finfo.h&r2=123303 ============================================================================== --- perl/modperl/trunk/xs/APR/Finfo/APR__Finfo.h (original) +++ perl/modperl/trunk/xs/APR/Finfo/APR__Finfo.h Fri Dec 24 13:58:50 2004 @@ -14,13 +14,18 @@ */ static MP_INLINE -apr_finfo_t *mpxs_APR__Finfo_stat(pTHX_ const char *fname, - apr_int32_t wanted, apr_pool_t *p) +SV *mpxs_APR__Finfo_stat(pTHX_ const char *fname, apr_int32_t wanted, + SV *p_sv) { + apr_pool_t *p = mp_xs_sv2_APR__Pool(p_sv); apr_finfo_t *finfo = (apr_finfo_t *)apr_pcalloc(p, sizeof(apr_finfo_t)); - + SV *finfo_sv; + MP_RUN_CROAK(apr_stat(finfo, fname, wanted, p), "APR::Finfo::stat"); - return finfo; + finfo_sv = sv_setref_pv(NEWSV(0, 0), "APR::Finfo", (void*)finfo); + mpxs_add_pool_magic(finfo_sv, p_sv); + + return finfo_sv; } Modified: perl/modperl/trunk/xs/APR/IpSubnet/APR__IpSubnet.h Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/xs/APR/IpSubnet/APR__IpSubnet.h?view=diff&rev=123303&p1=perl/modperl/trunk/xs/APR/IpSubnet/APR__IpSubnet.h&r1=123302&p2=perl/modperl/trunk/xs/APR/IpSubnet/APR__IpSubnet.h&r2=123303 ============================================================================== --- perl/modperl/trunk/xs/APR/IpSubnet/APR__IpSubnet.h (original) +++ perl/modperl/trunk/xs/APR/IpSubnet/APR__IpSubnet.h Fri Dec 24 13:58:50 2004 @@ -14,12 +14,16 @@ */ static MP_INLINE -apr_ipsubnet_t *mpxs_apr_ipsubnet_create(pTHX_ SV *classname, apr_pool_t *p, - const char *ipstr, - const char *mask_or_numbits) +SV *mpxs_apr_ipsubnet_create(pTHX_ SV *classname, SV *p_sv, + const char *ipstr, + const char *mask_or_numbits) { + apr_pool_t *p = mp_xs_sv2_APR__Pool(p_sv); apr_ipsubnet_t *ipsub = NULL; + SV *ipsub_sv; MP_RUN_CROAK(apr_ipsubnet_create(&ipsub, ipstr, mask_or_numbits, p), "APR::IpSubnet::new"); - return ipsub; + ipsub_sv = sv_setref_pv(NEWSV(0, 0), "APR::IpSubnet", (void*)ipsub); + mpxs_add_pool_magic(ipsub_sv, p_sv); + return ipsub_sv; } Modified: perl/modperl/trunk/xs/APR/Table/APR__Table.h Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/xs/APR/Table/APR__Table.h?view=diff&rev=123303&p1=perl/modperl/trunk/xs/APR/Table/APR__Table.h&r1=123302&p2=perl/modperl/trunk/xs/APR/Table/APR__Table.h&r2=123303 ============================================================================== --- perl/modperl/trunk/xs/APR/Table/APR__Table.h (original) +++ perl/modperl/trunk/xs/APR/Table/APR__Table.h Fri Dec 24 13:58:50 2004 @@ -17,6 +17,31 @@ #define mpxs_APR__Table_DELETE apr_table_unset #define mpxs_APR__Table_CLEAR apr_table_clear +#define MPXS_DO_TABLE_N_MAGIC_RETURN(call) \ + apr_pool_t *p = mp_xs_sv2_APR__Pool(p_sv); \ + apr_table_t *t = call; \ + SV *t_sv = modperl_hash_tie(aTHX_ "APR::Table", Nullsv, t); \ + mpxs_add_pool_magic(t_sv, p_sv); \ + return t_sv; + +static MP_INLINE SV *mpxs_APR__Table_make(pTHX_ SV *p_sv, int nelts) +{ + MPXS_DO_TABLE_N_MAGIC_RETURN(apr_table_make(p, nelts)); +} + + +static MP_INLINE SV *mpxs_APR__Table_copy(pTHX_ apr_table_t *base, SV *p_sv) +{ + MPXS_DO_TABLE_N_MAGIC_RETURN(apr_table_copy(p, base)); +} + +static MP_INLINE SV *mpxs_APR__Table_overlay(pTHX_ apr_table_t *base, + apr_table_t *overlay, SV *p_sv) +{ + MPXS_DO_TABLE_N_MAGIC_RETURN(apr_table_overlay(p, overlay, base)); +} + + typedef struct { SV *cv; apr_hash_t *filter; Modified: perl/modperl/trunk/xs/APR/ThreadMutex/APR__ThreadMutex.h Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/xs/APR/ThreadMutex/APR__ThreadMutex.h?view=diff&rev=123303&p1=perl/modperl/trunk/xs/APR/ThreadMutex/APR__ThreadMutex.h&r1=123302&p2=perl/modperl/trunk/xs/APR/ThreadMutex/APR__ThreadMutex.h&r2=123303 ============================================================================== --- perl/modperl/trunk/xs/APR/ThreadMutex/APR__ThreadMutex.h (original) +++ perl/modperl/trunk/xs/APR/ThreadMutex/APR__ThreadMutex.h Fri Dec 24 13:58:50 2004 @@ -16,11 +16,14 @@ #define apr_thread_mutex_DESTROY apr_thread_mutex_destroy static MP_INLINE -apr_thread_mutex_t *mpxs_apr_thread_mutex_create(pTHX_ SV *classname, - apr_pool_t *pool, - unsigned int flags) +SV *mpxs_apr_thread_mutex_create(pTHX_ SV *classname, SV *p_sv, + unsigned int flags) { + apr_pool_t *p = mp_xs_sv2_APR__Pool(p_sv); apr_thread_mutex_t *mutex = NULL; - (void)apr_thread_mutex_create(&mutex, flags, pool); - return mutex; + SV *mutex_sv; + (void)apr_thread_mutex_create(&mutex, flags, p); + mutex_sv = sv_setref_pv(NEWSV(0, 0), "APR::ThreadMutex", (void*)mutex); + mpxs_add_pool_magic(mutex_sv, p_sv); + return mutex_sv; } Modified: perl/modperl/trunk/xs/maps/apr_functions.map Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/xs/maps/apr_functions.map?view=diff&rev=123303&p1=perl/modperl/trunk/xs/maps/apr_functions.map&r1=123302&p2=perl/modperl/trunk/xs/maps/apr_functions.map&r2=123303 ============================================================================== --- perl/modperl/trunk/xs/maps/apr_functions.map (original) +++ perl/modperl/trunk/xs/maps/apr_functions.map Fri Dec 24 13:58:50 2004 @@ -80,7 +80,7 @@ apr_sockaddr_equal MODULE=APR::Brigade - apr_brigade_create | mpxs_ | SV *:CLASS, p, list | new + SV *:apr_brigade_create | mpxs_ | SV *:CLASS, SV *:p_sv, list | new ~apr_brigade_destroy mpxs_APR__Brigade_destroy !apr_brigade_partition @@ -124,7 +124,8 @@ void:DEFINE_destroy | | apr_bucket:bucket void:DEFINE_delete | | apr_bucket:bucket >apr_bucket_alloc - apr_bucket_alloc_create +~ apr_bucket_alloc_create + mpxs_APR__Bucket_alloc_create apr_bucket_alloc_destroy ~apr_bucket_setaside mpxs_APR__Bucket_setaside @@ -225,8 +226,8 @@ apr_global_mutex_unlock MODULE=APR::ThreadMutex PREFIX=apr_thread_mutex_ - apr_thread_mutex_t *:apr_thread_mutex_create | mpxs_ | \ - SV *:classname, pool, flags=APR_THREAD_MUTEX_DEFAULT | new + SV *:apr_thread_mutex_create | mpxs_ | \ + SV *:classname, SV *:p_sv, flags=APR_THREAD_MUTEX_DEFAULT | new void:apr_thread_mutex_destroy | | | apr_thread_mutex_DESTROY apr_thread_mutex_lock apr_thread_mutex_trylock @@ -244,10 +245,13 @@ MODULE=APR::Table apr_table_clear - apr_table_copy | | t, p - apr_table_make +~apr_table_copy + mpxs_APR__Table_copy +~apr_table_make + mpxs_APR__Table_make apr_table_overlap - apr_table_overlay | | base, overlay, p +~apr_table_overlay + mpxs_APR__Table_overlay apr_table_compress apr_table_add -apr_table_addn @@ -517,8 +521,8 @@ !apr_parse_addr_port MODULE=APR::IpSubnet - apr_ipsubnet_t *:apr_ipsubnet_create | mpxs_ | \ - SV *:CLASS, p, ipstr, mask_or_numbits=NULL | new + SV *:apr_ipsubnet_create | mpxs_ | \ + SV *:CLASS, SV *:p_sv, ipstr, mask_or_numbits=NULL | new apr_ipsubnet_test !MODULE=APR::Getopt Modified: perl/modperl/trunk/xs/modperl_xs_util.h Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/xs/modperl_xs_util.h?view=diff&rev=123303&p1=perl/modperl/trunk/xs/modperl_xs_util.h&r1=123302&p2=perl/modperl/trunk/xs/modperl_xs_util.h&r2=123303 ============================================================================== --- perl/modperl/trunk/xs/modperl_xs_util.h (original) +++ perl/modperl/trunk/xs/modperl_xs_util.h Fri Dec 24 13:58:50 2004 @@ -104,4 +104,20 @@ MARK++; \ } +/* several methods need to ensure that the pool that they take as an + * object doesn't go out of scope before the object that they return, + * since if this happens, the data contained in the later object + * becomes corrupted. this macro is used in various xs files where + * it's needed */ +#if ((PERL_REVISION == 5) && (PERL_VERSION >= 8)) + /* modperl_hash_tie already attached another _ext magic under + * 5.8+, so must use sv_magicext to have two magics with the + * type */ +#define mpxs_add_pool_magic(obj, pool_obj) \ + sv_magicext(SvRV(obj), pool_obj, PERL_MAGIC_ext, NULL, Nullch, -1) +#else +#define mpxs_add_pool_magic(obj) \ + sv_magic(SvRV(obj), pool_obj, PERL_MAGIC_ext, Nullch, -1) +#endif + #endif /* MODPERL_XS_H */ Modified: perl/modperl/trunk/xs/tables/current/ModPerl/FunctionTable.pm Url: http://svn.apache.org/viewcvs/perl/modperl/trunk/xs/tables/current/ModPerl/FunctionTable.pm?view=diff&rev=123303&p1=perl/modperl/trunk/xs/tables/current/ModPerl/FunctionTable.pm&r1=123302&p2=perl/modperl/trunk/xs/tables/current/ModPerl/FunctionTable.pm&r2=123303 ============================================================================== --- perl/modperl/trunk/xs/tables/current/ModPerl/FunctionTable.pm (original) +++ perl/modperl/trunk/xs/tables/current/ModPerl/FunctionTable.pm Fri Dec 24 13:58:50 2004 @@ -2,7 +2,7 @@ # !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # ! WARNING: generated by ModPerl::ParseSource/0.01 -# ! Thu Dec 23 11:37:35 2004 +# ! Fri Dec 24 16:06:42 2004 # ! do NOT edit, any changes will be lost ! # !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -5516,6 +5516,20 @@ ] }, { + 'return_type' => 'SV *', + 'name' => 'mpxs_APR__Bucket_alloc_create', + 'args' => [ + { + 'type' => 'PerlInterpreter *', + 'name' => 'my_perl' + }, + { + 'type' => 'SV *', + 'name' => 'p_sv' + } + ] + }, + { 'return_type' => 'void', 'name' => 'mpxs_APR__Bucket_insert_after', 'attr' => [ @@ -5657,17 +5671,17 @@ 'name' => 'my_perl' }, { - 'type' => 'apr_bucket *', - 'name' => 'b' + 'type' => 'SV *', + 'name' => 'b_sv' }, { - 'type' => 'apr_pool_t *', - 'name' => 'p' + 'type' => 'SV *', + 'name' => 'p_sv' } ] }, { - 'return_type' => 'apr_finfo_t *', + 'return_type' => 'SV *', 'name' => 'mpxs_APR__Finfo_stat', 'args' => [ { @@ -5683,8 +5697,8 @@ 'name' => 'wanted' }, { - 'type' => 'apr_pool_t *', - 'name' => 'p' + 'type' => 'SV *', + 'name' => 'p_sv' } ] }, @@ -5899,6 +5913,76 @@ ] }, { + 'return_type' => 'SV *', + 'name' => 'mpxs_APR__Table_copy', + 'attr' => [ + 'static', + '__inline__' + ], + 'args' => [ + { + 'type' => 'PerlInterpreter *', + 'name' => 'my_perl' + }, + { + 'type' => 'apr_table_t *', + 'name' => 'base' + }, + { + 'type' => 'SV *', + 'name' => 'p_sv' + } + ] + }, + { + 'return_type' => 'SV *', + 'name' => 'mpxs_APR__Table_make', + 'attr' => [ + 'static', + '__inline__' + ], + 'args' => [ + { + 'type' => 'PerlInterpreter *', + 'name' => 'my_perl' + }, + { + 'type' => 'SV *', + 'name' => 'p_sv' + }, + { + 'type' => 'int', + 'name' => 'nelts' + } + ] + }, + { + 'return_type' => 'SV *', + 'name' => 'mpxs_APR__Table_overlay', + 'attr' => [ + 'static', + '__inline__' + ], + 'args' => [ + { + 'type' => 'PerlInterpreter *', + 'name' => 'my_perl' + }, + { + 'type' => 'apr_table_t *', + 'name' => 'base' + }, + { + 'type' => 'apr_table_t *', + 'name' => 'overlay' + }, + { + 'type' => 'SV *', + 'name' => 'p_sv' + } + ] + }, + { 'return_type' => 'char *', 'name' => 'mpxs_APR__URI_port', 'args' => [ @@ -7534,7 +7618,7 @@ ] }, { - 'return_type' => 'apr_bucket_brigade *', + 'return_type' => 'SV *', 'name' => 'mpxs_apr_brigade_create', 'args' => [ { @@ -7546,8 +7630,8 @@ 'name' => 'CLASS' }, { - 'type' => 'apr_pool_t *', - 'name' => 'p' + 'type' => 'SV *', + 'name' => 'p_sv' }, { 'type' => 'apr_bucket_alloc_t *', @@ -7556,7 +7640,7 @@ ] }, { - 'return_type' => 'apr_ipsubnet_t *', + 'return_type' => 'SV *', 'name' => 'mpxs_apr_ipsubnet_create', 'args' => [ { @@ -7568,8 +7652,8 @@ 'name' => 'classname' }, { - 'type' => 'apr_pool_t *', - 'name' => 'p' + 'type' => 'SV *', + 'name' => 'p_sv' }, { 'type' => 'const char *', @@ -7791,7 +7875,7 @@ ] }, { - 'return_type' => 'apr_thread_mutex_t *', + 'return_type' => 'SV *', 'name' => 'mpxs_apr_thread_mutex_create', 'args' => [ { @@ -7803,8 +7887,8 @@ 'name' => 'classname' }, { - 'type' => 'apr_pool_t *', - 'name' => 'pool' + 'type' => 'SV *', + 'name' => 'p_sv' }, { 'type' => 'unsigned int',
