You are viewing a plain text version of this content. The canonical link for it is here.
Posted to modperl-cvs@perl.apache.org by st...@apache.org on 2005/04/29 00:18:43 UTC
svn commit: r165213 - in /perl/modperl/branches/clone-skip-unstable:
lib/ModPerl/ src/modules/perl/ t/apr-ext/ t/conf/ t/lib/TestAPRlib/
t/lib/TestCommon/ t/perl/ t/response/TestPerl/ todo/ xs/ xs/APR/Bucket/
xs/APR/Pool/ xs/APR/Table/ xs/maps/
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);