Author: stas Date: Thu Apr 28 15:18:42 2005 New Revision: 165213 URL: http://svn.apache.org/viewcvs?rev=165213&view=rev Log: working to support CLONE_SKIP
Added: perl/modperl/branches/clone-skip-unstable/t/perl/ithreads_cloning.t (with props) perl/modperl/branches/clone-skip-unstable/t/response/TestPerl/ithreads_cloning.pm (with props) Modified: perl/modperl/branches/clone-skip-unstable/lib/ModPerl/TypeMap.pm perl/modperl/branches/clone-skip-unstable/src/modules/perl/modperl_common_util.c perl/modperl/branches/clone-skip-unstable/src/modules/perl/modperl_common_util.h perl/modperl/branches/clone-skip-unstable/src/modules/perl/modperl_util.c perl/modperl/branches/clone-skip-unstable/t/apr-ext/pool.t perl/modperl/branches/clone-skip-unstable/t/apr-ext/table.t perl/modperl/branches/clone-skip-unstable/t/conf/modperl_extra.pl perl/modperl/branches/clone-skip-unstable/t/lib/TestAPRlib/pool.pm perl/modperl/branches/clone-skip-unstable/t/lib/TestAPRlib/table.pm perl/modperl/branches/clone-skip-unstable/t/lib/TestCommon/Utils.pm perl/modperl/branches/clone-skip-unstable/t/perl/ithreads.t perl/modperl/branches/clone-skip-unstable/todo/release perl/modperl/branches/clone-skip-unstable/xs/APR/Bucket/APR__Bucket.h perl/modperl/branches/clone-skip-unstable/xs/APR/Pool/APR__Pool.h perl/modperl/branches/clone-skip-unstable/xs/APR/Table/APR__Table.h perl/modperl/branches/clone-skip-unstable/xs/maps/apr_functions.map perl/modperl/branches/clone-skip-unstable/xs/typemap Modified: perl/modperl/branches/clone-skip-unstable/lib/ModPerl/TypeMap.pm URL: http://svn.apache.org/viewcvs/perl/modperl/branches/clone-skip-unstable/lib/ModPerl/TypeMap.pm?rev=165213&r1=165212&r2=165213&view=diff ============================================================================== --- perl/modperl/branches/clone-skip-unstable/lib/ModPerl/TypeMap.pm (original) +++ perl/modperl/branches/clone-skip-unstable/lib/ModPerl/TypeMap.pm Thu Apr 28 15:18:42 2005 @@ -499,8 +499,15 @@ $define = "mp_xs_${ptype}_2obj"; $code .= <<EOF; -#define $define(ptr) \\ -sv_setref_pv(sv_newmortal(), "$class", (void*)ptr) +MP_INLINE SV *$define(pTHX_ void *ptr); +MP_INLINE SV *$define(pTHX_ void *ptr) +{ + SV *rv = sv_setref_pv(sv_newmortal(), "$class", ptr); + if (ptr) { + MP_CLONE_INSERT_OBJ("$class", rv); + } + return rv; +} EOF Modified: perl/modperl/branches/clone-skip-unstable/src/modules/perl/modperl_common_util.c URL: http://svn.apache.org/viewcvs/perl/modperl/branches/clone-skip-unstable/src/modules/perl/modperl_common_util.c?rev=165213&r1=165212&r2=165213&view=diff ============================================================================== --- perl/modperl/branches/clone-skip-unstable/src/modules/perl/modperl_common_util.c (original) +++ perl/modperl/branches/clone-skip-unstable/src/modules/perl/modperl_common_util.c Thu Apr 28 15:18:42 2005 @@ -64,8 +64,9 @@ SV *hv = (SV*)newHV(); SV *rsv = sv_newmortal(); - sv_setref_pv(rsv, classname, p); - + SV *rv = sv_setref_pv(rsv, classname, p); + MP_CLONE_INSERT_OBJ("APR::Table", rv); + /* Prefetch magic requires perl 5.8 */ #if ((PERL_REVISION == 5) && (PERL_VERSION >= 8)) Modified: perl/modperl/branches/clone-skip-unstable/src/modules/perl/modperl_common_util.h URL: http://svn.apache.org/viewcvs/perl/modperl/branches/clone-skip-unstable/src/modules/perl/modperl_common_util.h?rev=165213&r1=165212&r2=165213&view=diff ============================================================================== --- perl/modperl/branches/clone-skip-unstable/src/modules/perl/modperl_common_util.h (original) +++ perl/modperl/branches/clone-skip-unstable/src/modules/perl/modperl_common_util.h Thu Apr 28 15:18:42 2005 @@ -97,5 +97,128 @@ SV *modperl_perl_gensym(pTHX_ char *pack); +/*** ithreads enabled perl CLONE support ***/ +#define MP_CLONE_DEBUG 1 + +#define MP_CLONE_HASH_NAME "::CLONE_objects" +#define MP_CLONE_HASH_NAME1 "CLONE_objects" +#define MP_CLONE_HASH_LEN1 13 + +/* some classes like APR::Table get the key in a different way and + * therefore should redefine this define */ +#define MP_CLONE_KEY_COMMON(obj) SvIVX(SvRV(obj)) + +#define MP_CLONE_GET_HV(namespace) \ + get_hv(Perl_form(aTHX_ "%s::%s", namespace, MP_CLONE_HASH_NAME), TRUE); + +#if MP_CLONE_DEBUG + +#define MP_CLONE_DEBUG_INSERT_KEY(namespace, obj) \ + Perl_warn(aTHX_ "%s %p: insert %s, %p => %p", \ + namespace, aTHX_ SvPV_nolen(sv_key), obj, SvRV(obj)); + +#define MP_CLONE_DEBUG_HOLLOW_KEY(namespace) \ + Perl_warn(aTHX_ "%s %p: hollow %s", namespace, \ + aTHX_ SvPVX(hv_iterkeysv(he))); + +#define MP_CLONE_DEBUG_DELETE_KEY(namespace) \ + Perl_warn(aTHX_ "%s %p: delete %s", namespace, aTHX_ SvPVX(sv_key)); + +#define MP_CLONE_DEBUG_CLONE(namespace) \ + Perl_warn(aTHX_ "%s %p: CLONE called", namespace, aTHX); + +#define MP_CLONE_DUMP_OBJECTS_HASH(namespace) \ + { \ + HE *he; \ + HV *hv = MP_CLONE_GET_HV(namespace); \ + Perl_warn(aTHX_ "%s %p: DUMP", namespace, aTHX); \ + hv_iterinit(hv); \ + while ((he = hv_iternext(hv))) { \ + SV *key = hv_iterkeysv(he); \ + SV *val = hv_iterval(hv, he); \ + Perl_warn(aTHX_ "\t%s => %p => %p\n", SvPVX(key), \ + val, SvRV(val)); \ + } \ + } + +#else /* if MP_CLONE_DEBUG */ + +#define MP_CLONE_DEBUG_INSERT_KEY(namespace, obj) +#define MP_CLONE_DEBUG_HOLLOW_KEY(namespace) +#define MP_CLONE_DEBUG_DELETE_KEY(namespace) +#define MP_CLONE_DEBUG_CLONE(namespace) +#define MP_CLONE_DUMP_OBJECTS_HASH(namespace) + +#endif /* if MP_CLONE_DEBUG */ + +#ifdef SvWEAKREF +#define WEAKEN(sv) sv_rvweaken(sv) +#else +#error "weak references are not implemented in this release of perl"); +#endif + +#define MP_CLONE_INSERT_OBJ(namespace, obj) \ + { \ + SV *weak_rv, *sv_key; \ + /* $objects{"$$self"} = $self; \ + Scalar::Util::weaken($objects{"$$self"}) \ + */ \ + HV *hv = MP_CLONE_GET_HV(namespace); \ +/* use the real object pointer as a unique key */ \ + sv_key = newSVpvf("%p", MP_CLONE_KEY_COMMON((obj))); \ + MP_CLONE_DEBUG_INSERT_KEY("a", (obj)); \ + weak_rv = newRV(SvRV((obj))); \ + WEAKEN(weak_rv); /* Ã la Scalar::Util::weaken */ \ + { \ + HE *ok = hv_store_ent(hv, sv_key, weak_rv, FALSE); \ + sv_free(sv_key); \ + if (ok == NULL) { \ + SvREFCNT_dec(weak_rv); \ + Perl_croak(aTHX_ "failed to insert into %%%s::%s", \ + namespace, MP_CLONE_HASH_NAME); \ + } \ + MP_CLONE_DUMP_OBJECTS_HASH(namespace); \ + } \ + } + +#define MP_CLONE_DO_CLONE(namespace, class) \ + { \ + HE *he; \ + HV *hv = MP_CLONE_GET_HV(namespace); \ + MP_CLONE_DEBUG_CLONE(namespace); \ + MP_CLONE_DUMP_OBJECTS_HASH(namespace); \ + hv_iterinit(hv); \ + while ((he = hv_iternext(hv))) { \ + SV *rv = hv_iterval(hv, he); \ + SV *sv = SvRV(rv); \ + /* sv_dump(rv); */ \ + MP_CLONE_DEBUG_HOLLOW_KEY(namespace); \ + if (sv) { \ + /* detach from the C struct and invalidate */ \ + mg_free(sv); /* remove any magic */ \ + SvFLAGS(sv) = 0; /* invalidate the sv */ \ + /* sv_free(sv); */ \ + } \ + /* sv_dump(sv); */ \ + /* sv_dump(rv); */ \ + SV *sv_key = hv_iterkeysv(he); \ + hv_delete_ent(hv, sv_key, G_DISCARD, FALSE); \ + } \ + MP_CLONE_DUMP_OBJECTS_HASH(namespace); \ + class = class; /* unused */ \ + } + +/* obj: SvRV'd object */ +#define MP_CLONE_DELETE_OBJ(namespace, obj) \ + { \ + HV *hv = MP_CLONE_GET_HV(namespace); \ + SV *sv_key = newSVpvf("%p", MP_CLONE_KEY_COMMON(obj)); \ + /* delete $CLONE_objects{"$$self"}; */ \ + MP_CLONE_DEBUG_DELETE_KEY(namespace); \ + hv_delete_ent(hv, sv_key, G_DISCARD, FALSE); \ + sv_free(sv_key); \ + MP_CLONE_DUMP_OBJECTS_HASH(namespace); \ + } + #endif /* MODPERL_COMMON_UTIL_H */ Modified: perl/modperl/branches/clone-skip-unstable/src/modules/perl/modperl_util.c URL: http://svn.apache.org/viewcvs/perl/modperl/branches/clone-skip-unstable/src/modules/perl/modperl_util.c?rev=165213&r1=165212&r2=165213&view=diff ============================================================================== --- perl/modperl/branches/clone-skip-unstable/src/modules/perl/modperl_util.c (original) +++ perl/modperl/branches/clone-skip-unstable/src/modules/perl/modperl_util.c Thu Apr 28 15:18:42 2005 @@ -192,11 +192,15 @@ MP_INLINE SV *modperl_ptr2obj(pTHX_ char *classname, void *ptr) { SV *sv = newSV(0); - + SV *rv; + MP_TRACE_h(MP_FUNC, "sv_setref_pv(%s, 0x%lx)\n", classname, (unsigned long)ptr); - sv_setref_pv(sv, classname, ptr); - + rv = sv_setref_pv(sv, classname, ptr); + if (ptr) { + MP_CLONE_INSERT_OBJ(classname, rv); + } + return sv; } Modified: perl/modperl/branches/clone-skip-unstable/t/apr-ext/pool.t URL: http://svn.apache.org/viewcvs/perl/modperl/branches/clone-skip-unstable/t/apr-ext/pool.t?rev=165213&r1=165212&r2=165213&view=diff ============================================================================== --- perl/modperl/branches/clone-skip-unstable/t/apr-ext/pool.t (original) +++ perl/modperl/branches/clone-skip-unstable/t/apr-ext/pool.t Thu Apr 28 15:18:42 2005 @@ -2,10 +2,14 @@ use strict; use warnings FATAL => 'all'; -use Apache::Test; + +use threads; use TestAPRlib::pool; +use Apache::Test; + plan tests => TestAPRlib::pool::num_of_tests(); TestAPRlib::pool::test(); + Modified: perl/modperl/branches/clone-skip-unstable/t/apr-ext/table.t URL: http://svn.apache.org/viewcvs/perl/modperl/branches/clone-skip-unstable/t/apr-ext/table.t?rev=165213&r1=165212&r2=165213&view=diff ============================================================================== --- perl/modperl/branches/clone-skip-unstable/t/apr-ext/table.t (original) +++ perl/modperl/branches/clone-skip-unstable/t/apr-ext/table.t Thu Apr 28 15:18:42 2005 @@ -2,6 +2,7 @@ use strict; use warnings FATAL => 'all'; +use Test::More (); use Apache::Test; use TestAPRlib::table; Modified: perl/modperl/branches/clone-skip-unstable/t/conf/modperl_extra.pl URL: http://svn.apache.org/viewcvs/perl/modperl/branches/clone-skip-unstable/t/conf/modperl_extra.pl?rev=165213&r1=165212&r2=165213&view=diff ============================================================================== --- perl/modperl/branches/clone-skip-unstable/t/conf/modperl_extra.pl (original) +++ perl/modperl/branches/clone-skip-unstable/t/conf/modperl_extra.pl Thu Apr 28 15:18:42 2005 @@ -29,6 +29,12 @@ use Apache2::Process (); use Apache2::Log (); +use TestCommon::Utils; +# XXX: must be loaded before Test::Builder gets loaded (via A-T or +# Test::More) so it'll get the threads right. +require threads if TestCommon::Utils::THREADS_OK; +# XXX: need to do the same for t/TEST for apr-ext tests + use Apache2::Const -compile => ':common'; reorg_INC(); Modified: perl/modperl/branches/clone-skip-unstable/t/lib/TestAPRlib/pool.pm URL: http://svn.apache.org/viewcvs/perl/modperl/branches/clone-skip-unstable/t/lib/TestAPRlib/pool.pm?rev=165213&r1=165212&r2=165213&view=diff ============================================================================== --- perl/modperl/branches/clone-skip-unstable/t/lib/TestAPRlib/pool.pm (original) +++ perl/modperl/branches/clone-skip-unstable/t/lib/TestAPRlib/pool.pm Thu Apr 28 15:18:42 2005 @@ -3,7 +3,9 @@ use strict; use warnings FATAL => 'all'; -use Apache::Test; +use TestCommon::Utils; + +use Apache::Test; # for a shared test counter under ithreads use Apache::TestUtil; use Apache::TestTrace; @@ -11,11 +13,28 @@ use APR::Table (); sub num_of_tests { - return 75; + my $runs = 1; + $runs += 3 if TestCommon::Utils::THREADS_OK; + + return $runs * 75; } sub test { + test_set(); + + return unless TestCommon::Utils::THREADS_OK; + + require threads; + our $p = APR::Pool->new; + my $threads = 2; + threads->new(\&test_set)->join for 1..$threads; + test_set(); # parent again + + #$_->join() for threads->list(); +} + +sub test_set { my $pool = APR::Pool->new(); my $table = APR::Table::make($pool, 2); @@ -407,6 +426,8 @@ #ok $num_bytes; } + + return undef; # a must for thread callback } # returns how many ancestor generations the pool has (parent, Modified: perl/modperl/branches/clone-skip-unstable/t/lib/TestAPRlib/table.pm URL: http://svn.apache.org/viewcvs/perl/modperl/branches/clone-skip-unstable/t/lib/TestAPRlib/table.pm?rev=165213&r1=165212&r2=165213&view=diff ============================================================================== --- perl/modperl/branches/clone-skip-unstable/t/lib/TestAPRlib/table.pm (original) +++ perl/modperl/branches/clone-skip-unstable/t/lib/TestAPRlib/table.pm Thu Apr 28 15:18:42 2005 @@ -5,29 +5,51 @@ use strict; use warnings FATAL => 'all'; +use Test::More (); use Apache::Test; use Apache::TestUtil; use APR::Table (); use APR::Pool (); +use TestCommon::Utils; + use APR::Const -compile => ':table'; use constant TABLE_SIZE => 20; our $filter_count; sub num_of_tests { - my $tests = 56; + my $runs = 1; + $runs += 3 if TestCommon::Utils::THREADS_OK; + my $tests = 56; # tied hash values() for a table w/ multiple values for the same # key $tests += 2 if $] >= 5.008; - return $tests; + return $tests * $runs; } sub test { + test_set(); + + return unless TestCommon::Utils::THREADS_OK; + + require threads; + our $p = APR::Pool->new; + my $threads = 2; + + threads->new(\&test_set)->join for 1..$threads; + test_set(); # parent again + + # XXX: at the moment serializing each run, since ok's gets + # interleaved with other otput when multple threads run at the + # same time + #$_->join() for threads->list(); +} +sub test_set { $filter_count = 0; my $pool = APR::Pool->new(); my $table = APR::Table::make($pool, TABLE_SIZE); Modified: perl/modperl/branches/clone-skip-unstable/t/lib/TestCommon/Utils.pm URL: http://svn.apache.org/viewcvs/perl/modperl/branches/clone-skip-unstable/t/lib/TestCommon/Utils.pm?rev=165213&r1=165212&r2=165213&view=diff ============================================================================== --- perl/modperl/branches/clone-skip-unstable/t/lib/TestCommon/Utils.pm (original) +++ perl/modperl/branches/clone-skip-unstable/t/lib/TestCommon/Utils.pm Thu Apr 28 15:18:42 2005 @@ -11,6 +11,9 @@ use Apache2::Const -compile => qw(MODE_READBYTES); use APR::Const -compile => qw(SUCCESS BLOCK_READ); +use Config; +use constant THREADS_OK => $] >= 5.008 && $Config{useithreads}; + use constant IOBUFSIZE => 8192; # perl 5.6.x only triggers taint protection on strings which are at Modified: perl/modperl/branches/clone-skip-unstable/t/perl/ithreads.t URL: http://svn.apache.org/viewcvs/perl/modperl/branches/clone-skip-unstable/t/perl/ithreads.t?rev=165213&r1=165212&r2=165213&view=diff ============================================================================== --- perl/modperl/branches/clone-skip-unstable/t/perl/ithreads.t (original) +++ perl/modperl/branches/clone-skip-unstable/t/perl/ithreads.t Thu Apr 28 15:18:42 2005 @@ -8,9 +8,11 @@ # perl < 5.6.0 fails to compile code with 'shared' attributes, so we must skip # it here. -unless ($] >= 5.008001 && $Config{useithreads}) { - plan tests => 1, need - {"perl 5.8.1 or higher w/ithreads enabled is required" => 0}; -} +#unless ($] >= 5.008001 && $Config{useithreads}) { +# plan tests => 1, need +# {"perl 5.8.1 or higher w/ithreads enabled is required" => 0}; +#} + +plan tests => 1, under_construction; print GET_BODY_ASSERT "/TestPerl__ithreads"; Added: perl/modperl/branches/clone-skip-unstable/t/perl/ithreads_cloning.t URL: http://svn.apache.org/viewcvs/perl/modperl/branches/clone-skip-unstable/t/perl/ithreads_cloning.t?rev=165213&view=auto ============================================================================== --- perl/modperl/branches/clone-skip-unstable/t/perl/ithreads_cloning.t (added) +++ perl/modperl/branches/clone-skip-unstable/t/perl/ithreads_cloning.t Thu Apr 28 15:18:42 2005 @@ -0,0 +1,16 @@ +# WARNING: this file is generated, do not edit +# 01: /home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestConfig.pm:927 +# 02: /home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestConfig.pm:945 +# 03: /home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestConfigPerl.pm:135 +# 04: /home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestConfigPerl.pm:550 +# 05: /home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestConfig.pm:613 +# 06: /home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestConfig.pm:628 +# 07: /home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestConfig.pm:1562 +# 08: /home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestRun.pm:506 +# 09: /home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestRunPerl.pm:84 +# 10: /home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestRun.pm:725 +# 11: /home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestRun.pm:725 +# 12: t/TEST:21 + +use Apache::TestRequest 'GET_BODY_ASSERT'; +print GET_BODY_ASSERT "/TestPerl__ithreads_cloning"; Propchange: perl/modperl/branches/clone-skip-unstable/t/perl/ithreads_cloning.t ------------------------------------------------------------------------------ svn:eol-style = native Added: perl/modperl/branches/clone-skip-unstable/t/response/TestPerl/ithreads_cloning.pm URL: http://svn.apache.org/viewcvs/perl/modperl/branches/clone-skip-unstable/t/response/TestPerl/ithreads_cloning.pm?rev=165213&view=auto ============================================================================== --- perl/modperl/branches/clone-skip-unstable/t/response/TestPerl/ithreads_cloning.pm (added) +++ perl/modperl/branches/clone-skip-unstable/t/response/TestPerl/ithreads_cloning.pm Thu Apr 28 15:18:42 2005 @@ -0,0 +1,135 @@ +package TestPerl::ithreads_cloning; + +# a few basic tests on how mp2 objects deal with cloning (used +# APR::Table and APR::Pool for the tests) +# + +use strict; +use warnings FATAL => 'all'; + +use APR::Table (); +use APR::Pool (); + +use Apache::Test; +use Apache::TestUtil; + +use TestCommon::Utils; + +use Devel::Peek; + +use Apache2::Const -compile => 'OK'; + +my $pool_ext = APR::Pool->new; +my $table_ext1 = APR::Table::make($pool_ext, 10); +my $table_ext2 = APR::Table::make($pool_ext, 10); + +my $threads = 2; + +sub handler { + my $r = shift; + + my $tests = 10 * (2 + $threads); + plan $r, tests => $tests, need + need_threads, + {"perl >= 5.8.1 is required (this is $])" => ($] >= 5.008001)}; + + require threads; + threads->import(); + + read_test(); + #Dump $pool_ext; + #Dump $table_ext1; + threads->new(\&read_test)->join() for 1..$threads; + #Dump $pool_ext; + #Dump $table_ext1; + read_test(); + + Apache2::Const::OK; +} + +# 10 subtests +sub read_test { + my $tid = threads->self()->tid(); + t_debug "tid: $tid"; + + { + # use of invalidated cloned object + my $error_msg = q[Can't call method "set" on unblessed reference]; + eval { $table_ext1->set(1 => 2); }; + if ($tid > 0) { # child thread + # set must fail, since $table_ext1 must have been invalidated + ok t_cmp $@, qr/\Q$error_msg/, + '$table_ext1 must have been invalidated'; + } + else { + # should work just fine for the parent "thread", which + # created this variable + ok !$@; + } + } + + { + # use of invalidated cloned object as an argument + my $error_msg = 'argument is not a blessed reference ' . + '(expecting an APR::Pool derived object)'; + eval { my $table = APR::Table::make($pool_ext, 10) }; + if ($tid > 0) { # child thread + # make() must fail, since $pool_ext must have been invalidated + ok t_cmp $@, qr/\Q$error_msg/, + '$pool_ext must have been invalidated'; + } + else { + # should work just fine for the parent "thread", which + # created this variable + ok !$@; + } + } + + { + # this is an important test, since the thread assigns a new + # value to the cloned $table_ext1 (since it existed before the + # thread was started) + + my $save = $table_ext1; + + $table_ext1 = APR::Table::make(APR::Pool->new, 10); + + validate($table_ext1); + + $table_ext1 = $save; + } + + { + # here $table_ext2 is a private variable, so the cloned + # variable $table_ext2 is not touched + my $table_ext2 = APR::Table::make(APR::Pool->new, 10); + + validate($table_ext2); + } + + return undef; +} + +# 4 subtests +sub validate { + my $t = shift; + my $tid = threads->self()->tid(); + + $t->set($_ => $_) for 1..20; + for my $count (1..2) { + my $expected = 20; + my $received = $t->get(20); + is $received, $expected, "tid: $tid: pass 1:"; + $t->set(20 => 40); + $received = $t->get(20); + $expected = 40; + is $received, $expected, "tid: $tid: pass 2:"; + # reset + $t->set(20 => 20); + } +} + +1; + +__END__ + Propchange: perl/modperl/branches/clone-skip-unstable/t/response/TestPerl/ithreads_cloning.pm ------------------------------------------------------------------------------ svn:eol-style = native Modified: perl/modperl/branches/clone-skip-unstable/todo/release URL: http://svn.apache.org/viewcvs/perl/modperl/branches/clone-skip-unstable/todo/release?rev=165213&r1=165212&r2=165213&view=diff ============================================================================== --- perl/modperl/branches/clone-skip-unstable/todo/release (original) +++ perl/modperl/branches/clone-skip-unstable/todo/release Thu Apr 28 15:18:42 2005 @@ -44,3 +44,91 @@ happy). Not sure what's the best solution here. --------------- + +Making mp2 API perl-thread-safe +owner: stas + +Status: + +V = done +N = creates no objects +- = not started ++ = in progress + +1) + +-- APR::Bucket +-- APR::BucketType +V- APR::Pool +-- APR::SockAddr +-- APR::Socket +V- APR::Table +-- APR::UUID + +2) + +-- APR::Brigade xs/APR/Brigade/APR__Brigade.h: SV *bb_sv = sv_setref_pv(NEWSV(0, 0), "APR::Brigade", (void*)bb); +-- APR::BucketAlloc xs/APR/BucketAlloc/APR__BucketAlloc.h: SV *ba_sv = sv_setref_pv(NEWSV(0, 0), "APR::BucketAlloc", (void*)ba); +-- APR::Error (not sure about this one, should probably handle as well) +-- APR::Finfo xs/APR/Finfo/APR__Finfo.h: finfo_sv = sv_setref_pv(NEWSV(0, 0), "APR::Finfo", (void*)finfo); +-- APR::IpSubnet xs/APR/IpSubnet/APR__IpSubnet.h: ipsub_sv = sv_setref_pv(NEWSV(0, 0), "APR::IpSubnet", (void*)ipsub); +-- APR::ThreadMutex xs/APR/ThreadMutex/APR__ThreadMutex.h: mutex_sv = sv_setref_pv(NEWSV(0, 0), "APR::ThreadMutex", (void*)mutex); +-- APR::URI xs/APR/URI/APR__URI.h: uri_sv = sv_setref_pv(NEWSV(0, 0), "APR::URI", (void*)uri); + +3) + +-- Apache::CmdParms +-- Apache::Command +-- Apache::Connection +-- Apache::Directive +-- Apache::Filter +-- Apache::FilterRec +-- Apache::ServerRec +-- Apache::SubRequest +-- Apache::Module +-- Apache::Process + +4) +-- Apache::Log xs/Apache/Log/Apache__Log.h: sv_setref_pv(svretval, pclass, (void*)retval); +-- Apache::RequestRec + src/modules/perl/modperl_io.c: sv_setref_pv(sv, "Apache::RequestRec", (void*)r); + src/modules/perl/modperl_io.c: sv_setref_pv(sv, "Apache::RequestRec", (void*)r); + src/modules/perl/modperl_io_apache.c: sv_setref_pv(sv, "Apache::RequestRec", (void*)(st->r)); + xs/Apache/RequestUtil/Apache__RequestUtil.h: r_sv = sv_setref_pv(NEWSV(0, 0), "Apache::RequestRec", (void*)r); + + +4) The following too (needs more detailed lookthrough): + +V- src/modules/perl/modperl_util.c: sv_setref_pv(sv, classname, ptr); +V- src/modules/perl/modperl_common_util.c: sv_setref_pv(rsv, classname, p); +V- xs/typemap: sv_setref_pv($arg, \"${ntype}\", (void*)$var); +V- xs/typemap: sv_setref_pv($arg, \"${ntype}\", (void*)$var); + +XXX: also grep for sv_bless + ++ need to add DESTROY and CLONE methods to all the classes that we +have the objects blessed into + +None of the following classes is used to bless object and therefore +they require no special CLONE handling: + +N- Apache::Access +N- Apache::HookRun +N- Apache::MPM +N- Apache::RequestIO +N- Apache::RequestUtil +N- Apache::Response +N- Apache::ServerUtil +N- Apache::SubProcess +N- Apache::URI +N- Apache::Util +N- APR::Base64 +N- APR::Date +N- APR::OS +N- APR::String +N- APR::Util +N- ModPerl::Global +N- ModPerl::Util + + + Modified: perl/modperl/branches/clone-skip-unstable/xs/APR/Bucket/APR__Bucket.h URL: http://svn.apache.org/viewcvs/perl/modperl/branches/clone-skip-unstable/xs/APR/Bucket/APR__Bucket.h?rev=165213&r1=165212&r2=165213&view=diff ============================================================================== --- perl/modperl/branches/clone-skip-unstable/xs/APR/Bucket/APR__Bucket.h (original) +++ perl/modperl/branches/clone-skip-unstable/xs/APR/Bucket/APR__Bucket.h Thu Apr 28 15:18:42 2005 @@ -78,6 +78,11 @@ return APR_BUCKET_IS_EOS(bucket); } +static MP_INLINE int mpxs_APR__Bucket_is_eoc(apr_bucket *bucket) +{ + return APR_BUCKET_IS_EOC(bucket); +} + static MP_INLINE int mpxs_APR__Bucket_is_flush(apr_bucket *bucket) { return APR_BUCKET_IS_FLUSH(bucket); Modified: perl/modperl/branches/clone-skip-unstable/xs/APR/Pool/APR__Pool.h URL: http://svn.apache.org/viewcvs/perl/modperl/branches/clone-skip-unstable/xs/APR/Pool/APR__Pool.h?rev=165213&r1=165212&r2=165213&view=diff ============================================================================== --- perl/modperl/branches/clone-skip-unstable/xs/APR/Pool/APR__Pool.h (original) +++ perl/modperl/branches/clone-skip-unstable/xs/APR/Pool/APR__Pool.h Thu Apr 28 15:18:42 2005 @@ -23,20 +23,6 @@ #endif } mpxs_pool_account_t; -/* XXX: this implementation has a problem with perl ithreads. if a - * custom pool is allocated, and then a thread is spawned we now have - * two copies of the pool object, each living in a different perl - * interpreter, both pointing to the same memory address of the apr - * pool. - * - * need to write a CLONE class method could properly clone the - * thread's copied object, but it's tricky: - * - it needs to call parent_get() on the copied object and allocate a - * new pool from that parent's pool - * - it needs to reinstall any registered cleanup callbacks (can we do - * that?) may be we can skip those? - */ - #ifndef MP_SOURCE_SCAN #include "apr_optional.h" static @@ -216,6 +202,8 @@ if (parent_pool) { mpxs_add_pool_magic(rv, parent_pool_obj); } + + MP_CLONE_INSERT_OBJ("APR::Pool", rv); return rv; } @@ -351,7 +339,7 @@ apr_pool_t *parent_pool = apr_pool_parent_get(child_pool); if (parent_pool) { - return SvREFCNT_inc(mp_xs_APR__Pool_2obj(parent_pool)); + return SvREFCNT_inc(mp_xs_APR__Pool_2obj(aTHX_ parent_pool)); } else { MP_POOL_TRACE(MP_FUNC, "pool (0x%lx) has no parents", @@ -368,9 +356,20 @@ { SV *sv = SvRV(obj); + MP_CLONE_DELETE_OBJ("APR::Pool", obj); + if (MP_APR_POOL_SV_HAS_OWNERSHIP(sv)) { + //Perl_warn(aTHX_ "APR::Pool %p: DESTROY %p => %p", aTHX_ obj, sv); apr_pool_t *p = mpxs_sv_object_deref(obj, apr_pool_t); apr_pool_destroy(p); + } + + if (MP_APR_POOL_SV_HAS_OWNERSHIP(sv)) { + /* do *not* merge this with the next conditional */ + + } + } +#define mpxs_APR__Pool_CLONE(class) MP_CLONE_DO_CLONE("APR::Pool", class) Modified: perl/modperl/branches/clone-skip-unstable/xs/APR/Table/APR__Table.h URL: http://svn.apache.org/viewcvs/perl/modperl/branches/clone-skip-unstable/xs/APR/Table/APR__Table.h?rev=165213&r1=165212&r2=165213&view=diff ============================================================================== --- perl/modperl/branches/clone-skip-unstable/xs/APR/Table/APR__Table.h (original) +++ perl/modperl/branches/clone-skip-unstable/xs/APR/Table/APR__Table.h Thu Apr 28 15:18:42 2005 @@ -17,11 +17,17 @@ #define mpxs_APR__Table_DELETE apr_table_unset #define mpxs_APR__Table_CLEAR apr_table_clear +/* redefine the key method */ +#undef MP_CLONE_KEY_COMMON +#define MP_CLONE_KEY_COMMON(obj) \ + modperl_hash_tied_object(aTHX_ "APR::Table", obj) + #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); \ + MP_CLONE_INSERT_OBJ("APR::Table", t_sv); \ return t_sv; static MP_INLINE SV *mpxs_APR__Table_make(pTHX_ SV *p_sv, int nelts) @@ -29,7 +35,6 @@ 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)); @@ -192,7 +197,6 @@ } } - MP_STATIC XS(MPXS_apr_table_get) { dXSARGS; @@ -231,3 +235,8 @@ }); } + +#define mpxs_APR__Table_CLONE(class) MP_CLONE_DO_CLONE("APR::Table", class) + +#define mpxs_APR__Table_DESTROY(obj) MP_CLONE_DELETE_OBJ("APR::Table", obj); + Modified: perl/modperl/branches/clone-skip-unstable/xs/maps/apr_functions.map URL: http://svn.apache.org/viewcvs/perl/modperl/branches/clone-skip-unstable/xs/maps/apr_functions.map?rev=165213&r1=165212&r2=165213&view=diff ============================================================================== --- perl/modperl/branches/clone-skip-unstable/xs/maps/apr_functions.map (original) +++ perl/modperl/branches/clone-skip-unstable/xs/maps/apr_functions.map Thu Apr 28 15:18:42 2005 @@ -174,6 +174,7 @@ ~apr_pool_destroy DEFINE_destroy | mpxs_apr_pool_DESTROY | SV *:obj DEFINE_DESTROY | mpxs_apr_pool_DESTROY | SV *:obj + DEFINE_CLONE | | SV *:class >apr_pool_destroy_debug SV *:DEFINE_new | mpxs_apr_pool_create | SV *:parent_pool_obj -apr_pool_create_ex @@ -246,6 +247,8 @@ apr_proc_mutex_unlock MODULE=APR::Table + DEFINE_CLONE | | SV *:class + DEFINE_DESTROY | | SV *:obj apr_table_clear ~apr_table_copy mpxs_APR__Table_copy Modified: perl/modperl/branches/clone-skip-unstable/xs/typemap URL: http://svn.apache.org/viewcvs/perl/modperl/branches/clone-skip-unstable/xs/typemap?rev=165213&r1=165212&r2=165213&view=diff ============================================================================== --- perl/modperl/branches/clone-skip-unstable/xs/typemap (original) +++ perl/modperl/branches/clone-skip-unstable/xs/typemap Thu Apr 28 15:18:42 2005 @@ -6,10 +6,20 @@ ###################################################################### OUTPUT T_POOLOBJ - sv_setref_pv($arg, \"${ntype}\", (void*)$var); + { + SV *rv = sv_setref_pv($arg, \"${ntype}\", (void*)$var); + if ($var) { + MP_CLONE_INSERT_OBJ("APR::Pool", rv); + } + } T_APACHEOBJ - sv_setref_pv($arg, \"${ntype}\", (void*)$var); + { + SV *rv = sv_setref_pv($arg, \"${ntype}\", (void*)$var); + if ($var) { + MP_CLONE_INSERT_OBJ("APR::Pool", rv); + } + } T_HASHOBJ $arg = modperl_hash_tie(aTHX_ \"${ntype}\", $arg, $var);