Stas Bekman wrote:
Have done some good but painfully slow progress, now partially covering APR::Table and APR::Pool. In case you care to look here is the work in progress. I wonder if I should branch that since there are going to be *a lot* of additions if this ever works.
My main obstacle at the moment is the testing environment under threads. I get interleaving messages from different threads (SMP/HyperThread CPU here so I get real multiple threads running at the same time.). So at times Test::Harness get confused:
ok 219
Confused test output: test 218 answered after test 218
# expected: 1
# testing : a dead pool is a dead pool
# expected: (?-xism:invalid pool object)
# received: invalid pool object (already destroyed?) at /home/stas/apache.org/mp2-svn/t/lib/TestAPRlib/pool.pm line 197.
# received: inok 220
# testing : should be 1 note
# expected: 1
# received: 1
ok 221
here ok 220 got interleaved with a log from another thread. I'm afraid Test::More/Apache::Test need more work and do STDERR locking when working in the threaded environment.
Anyway, here is some code:
Index: src/modules/perl/modperl_common_util.h =================================================================== --- src/modules/perl/modperl_common_util.h (revision 159153) +++ src/modules/perl/modperl_common_util.h (working copy) @@ -97,5 +97,122 @@
SV *modperl_perl_gensym(pTHX_ char *pack);
+/*** ithreads enabled perl CLONE support ***/
+#define MP_CLONE_DEBUG 0
+
+#define MP_CLONE_HASH_NAME "::CLONE_objects"
+
+#define MP_CLONE_KEY_COMMON(obj) SvIVX(SvRV(obj))
+
+
+#if MP_CLONE_DEBUG
+
+#define MP_CLONE_DEBUG_INSERT_KEY(namespace, obj) \
+ Perl_warn(aTHX_ "%s %p: insert %s, %p => %p\n", \
+ namespace, aTHX_ SvPV_nolen(sv_key), obj, SvRV(obj));
+#define MP_CLONE_DEBUG_HOLLOW_KEY(namespace) \
+ Perl_warn(aTHX_ "%s %p: hollow %s\n", namespace, \
+ aTHX_ SvPVX(hv_iterkeysv(he)));
+#define MP_CLONE_DEBUG_DELETE_KEY(namespace) \
+ Perl_warn(aTHX_ "%s %p: delete %s\n", namespace, aTHX_ SvPVX(sv_key));
+
+#define MP_CLONE_DEBUG_CLONE(namespace) \
+ Perl_warn(aTHX_ "%s %p: CLONE called\n", namespace, aTHX);
+
+#define MP_CLONE_DUMP_OBJECTS_HASH(namespace) \
+ { \
+ HE *he; \
+ HV *hv = get_hv(namespace MP_CLONE_HASH_NAME, TRUE); \
+ 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
+
+#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
+
+#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 = get_hv(namespace MP_CLONE_HASH_NAME, TRUE); \
+ /* use the real object pointer as a unique key */ \
+ sv_key = newSVpvf("%p", MP_CLONE_KEY_COMMON(obj)); \
+ MP_CLONE_DEBUG_INSERT_KEY(namespace, obj); \
+ weak_rv = newRV(SvRV(obj)); \
+ WEAKEN(weak_rv); /* ala 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", \
+ namespace MP_CLONE_HASH_NAME); \
+ } \
+ MP_CLONE_DUMP_OBJECTS_HASH(namespace); \
+ } \
+ }
+
+#define MP_CLONE_DO_CLONE(namespace, class) \
+ { \
+ HE *he; \
+ HV *hv = get_hv(namespace MP_CLONE_HASH_NAME, TRUE); \
+ 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 form the C struct and invalidate */ \
+ mg_free(sv); /* remove any magic */ \
+ SvOK_off(sv); \
+ SvIVX(sv) = 0; \
+ SvOBJECT_off(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 = get_hv(namespace MP_CLONE_HASH_NAME, TRUE); \
+ 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 */Index: xs/maps/apr_functions.map =================================================================== --- xs/maps/apr_functions.map (revision 159153) +++ xs/maps/apr_functions.map (working copy) @@ -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 Index: xs/APR/Table/APR__Table.h =================================================================== --- xs/APR/Table/APR__Table.h (revision 159153) +++ xs/APR/Table/APR__Table.h (working copy) @@ -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)
@@ -192,7 +198,6 @@
}
}-
MP_STATIC XS(MPXS_apr_table_get)
{
dXSARGS;
@@ -211,7 +216,7 @@ if (GIMME_V == G_SCALAR) {
const char *val = apr_table_get(t, key);
-
+
if (val) {
XPUSHs(sv_2mortal(newSVpv((char*)val, 0)));
}
@@ -231,3 +236,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);
+
Index: xs/APR/Pool/APR__Pool.h
===================================================================
--- xs/APR/Pool/APR__Pool.h (revision 159153)
+++ xs/APR/Pool/APR__Pool.h (working copy)
@@ -216,6 +216,8 @@
if (parent_pool) {
mpxs_add_pool_magic(rv, parent_pool_obj);
}
+
+ MP_CLONE_INSERT_OBJ("APR::Pool", rv); return rv;
}
@@ -368,9 +370,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)
Index: t/apr-ext/table.t
===================================================================
--- t/apr-ext/table.t (revision 159153)
+++ t/apr-ext/table.t (working copy)
@@ -1,11 +1,70 @@
-#!perl -T
+#!perluse strict; use warnings FATAL => 'all'; -use Apache::Test;
-use TestAPRlib::table; +use threads; +use threads::shared;
-plan tests => TestAPRlib::table::num_of_tests(); +use Apache::Test '-withtestmore';
-TestAPRlib::table::test();
+use APR::Table ();
+use APR::Pool ();
+use Apache::TestUtil;
+
+use Config;
+use constant THREADS_OK => $] >= 5.008 && $Config{useithreads};
+
+use Devel::Peek;
+
+#use TestAPRlib::table;
+#plan tests => TestAPRlib::table::num_of_tests();
+#TestAPRlib::table::test();
+
+my $pool = APR::Pool->new;
+my $t = APR::Table::make($pool, 10);
+
+plan tests => 2*8;
+test_threads();
+
+# perl-ithreads specific testing
+sub test_threads {
+
+ my $threads = 2;
+
+ return unless THREADS_OK;
+
+ read_test();
+ threads->new(\&read_test) for 1..$threads;
+ read_test();
+
+ $_->join() for threads->list();
+
+}
+
+sub read_test : locked {
+ my $tid = threads->self()->tid();
+ t_debug "tid: $tid";
+
+ my $pool = APR::Pool->new;
+
+ #Dump $t;
+ $t = APR::Table::make($pool, 10);
+ #Dump $t;
+
+ $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);
+ }
+
+ return undef;
+}
Index: t/apr-ext/pool.t
===================================================================
--- t/apr-ext/pool.t (revision 159153)
+++ t/apr-ext/pool.t (working copy)
@@ -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(); + Index: t/conf/modperl_extra.pl =================================================================== --- t/conf/modperl_extra.pl (revision 159153) +++ t/conf/modperl_extra.pl (working copy) @@ -35,6 +35,9 @@
reorg_INC();
+
+use threads; # XXX: must be loaded before Test::Builder gets loaded (via A-T or Test::More) so it'll get the threads right.
+
startup_info();
test_add_config(); Index: t/response/TestAPR/pool.pm =================================================================== --- t/response/TestAPR/pool.pm (revision 159153) +++ t/response/TestAPR/pool.pm (working copy) @@ -3,7 +3,7 @@ use strict; use warnings FATAL => 'all';
-use Apache::Test; +use Apache::Test '-withtestmore'; # for a shared test counter under ithreads; use Apache::TestUtil; use Apache::TestTrace;
Index: t/lib/TestCommon/Utils.pm =================================================================== --- t/lib/TestCommon/Utils.pm (revision 159153) +++ t/lib/TestCommon/Utils.pm (working copy) @@ -10,6 +10,9 @@ use Apache::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 Index: t/lib/TestAPRlib/table.pm =================================================================== --- t/lib/TestAPRlib/table.pm (revision 159153) +++ t/lib/TestAPRlib/table.pm (working copy) @@ -16,6 +16,9 @@ use constant TABLE_SIZE => 20; our $filter_count;
+use Config;
+use constant THREADS_OK => $] >= 5.008 && $Config{useithreads};
+
sub num_of_tests {
my $tests = 56;@@ -368,4 +371,39 @@
return $filter_count == int(TABLE_SIZE)/2 ? 0 : 1;
}+
+our $t;
+# perl-ithreads specific testing
+sub test_threads {
+
+ my $threads = 2;
+
+ return unless THREADS_OK;
+
+ require threads;
+ require threads::shared;
+
+ $t = APR::Table::make(APR::Pool->new, 10);
+ $t->set($_ => $_) for 1..20;
+
+ read_test();
+ threads->new(\&read_test) for 1..$threads;
+ read_test();
+}
+
+sub read_test : locked {
+ my $tid = threads->self()->tid();
+ for my $count (1..2) {
+ my $expected = 20;
+ my $received = $t->get(20);
+ ok $received, $expected, "tid: $tid: pass 1:";
+ $t->set(20 => 40);
+ $received = $t->get(20);
+ $expected = 40;
+ ok $received, $expected, "tid: $tid: pass 2:";
+ # reset
+ $t->set(20 => 20);
+ }
+}
+
1;
Index: t/lib/TestAPRlib/pool.pm
===================================================================
--- t/lib/TestAPRlib/pool.pm (revision 159153)
+++ t/lib/TestAPRlib/pool.pm (working copy)
@@ -3,7 +3,9 @@
use strict;
use warnings FATAL => 'all';-use Apache::Test; +use TestCommon::Utils; + +use Apache::Test '-withtestmore'; # 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) 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,
-- __________________________________________________________________ Stas Bekman JAm_pH ------> Just Another mod_perl Hacker http://stason.org/ mod_perl Guide ---> http://perl.apache.org mailto:[EMAIL PROTECTED] http://use.perl.org http://apacheweek.com http://modperlbook.org http://apache.org http://ticketmaster.com
--------------------------------------------------------------------- To unsubscribe, e-mail: [EMAIL PROTECTED] For additional commands, e-mail: [EMAIL PROTECTED]
