I've now added support for CLONE_SKIP().
To do this, I stole the SVf_SCREAM flag for use on HVs (since you can't
study() a HV), now renamed SVphv_CLONEABLE.
At the start of cloning, CLONE_SKIP() is called (in the context of the
parent) for each class, and so each stash gets its flag set or unset as
appropriate. Then during cloning, objects whose stashes have the flag
unset don't get cloned.
Dave.
--
The warp engines start playing up a bit, but seem to sort themselves out
after a while without any intervention from boy genius Wesley Crusher.
-- Things That Never Happen in "Star Trek" #17
Change 24247 by [EMAIL PROTECTED] on 2005/04/19 01:38:54
Add CLONE_SKIP() class method to allow individual classes to skip
cloning objects during thread creation
Affected files ...
... //depot/perl/dump.c#165 edit
... //depot/perl/ext/threads/t/thread.t#11 edit
... //depot/perl/pod/perlmod.pod#36 edit
... //depot/perl/sv.c#801 edit
... //depot/perl/sv.h#174 edit
Differences ...
==== //depot/perl/dump.c#165 (text) ====
@@ -1136,7 +1136,8 @@
if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
if (flags & SVp_POK) sv_catpv(d, "pPOK,");
- if (flags & SVp_SCREAM) sv_catpv(d, "SCREAM,");
+ if (flags & SVp_SCREAM && type != SVt_PVHV)
+ sv_catpv(d, "SCREAM,");
switch (type) {
case SVt_PVCV:
@@ -1159,6 +1160,7 @@
if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
+ if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
break;
case SVt_PVGV: case SVt_PVLV:
if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
==== //depot/perl/ext/threads/t/thread.t#11 (text) ====
@@ -12,7 +12,7 @@
use ExtUtils::testlib;
use strict;
-BEGIN { $| = 1; print "1..26\n" };
+BEGIN { $| = 1; print "1..31\n" };
use threads;
use threads::shared;
@@ -159,4 +159,114 @@
'use threads; sub a{threads->new(shift)} $t = a sub{}; $t->tid; $t->join;
$t->tid');
is($?, 0, 'coredump in global destruction');
+# test CLONE_SKIP() functionality
+
+{
+ my %c : shared;
+ my %d : shared;
+
+ # ---
+
+ package A;
+ sub CLONE_SKIP { $c{"A-$_[0]"}++; 1; }
+ sub DESTROY { $d{"A-". ref $_[0]}++ }
+
+ package A1;
+ our @ISA = qw(A);
+ sub CLONE_SKIP { $c{"A1-$_[0]"}++; 1; }
+ sub DESTROY { $d{"A1-". ref $_[0]}++ }
+
+ package A2;
+ our @ISA = qw(A1);
+
+ # ---
+
+ package B;
+ sub CLONE_SKIP { $c{"B-$_[0]"}++; 0; }
+ sub DESTROY { $d{"B-" . ref $_[0]}++ }
+
+ package B1;
+ our @ISA = qw(B);
+ sub CLONE_SKIP { $c{"B1-$_[0]"}++; 1; }
+ sub DESTROY { $d{"B1-" . ref $_[0]}++ }
+
+ package B2;
+ our @ISA = qw(B1);
+
+ # ---
+
+ package C;
+ sub CLONE_SKIP { $c{"C-$_[0]"}++; 1; }
+ sub DESTROY { $d{"C-" . ref $_[0]}++ }
+
+ package C1;
+ our @ISA = qw(C);
+ sub CLONE_SKIP { $c{"C1-$_[0]"}++; 0; }
+ sub DESTROY { $d{"C1-" . ref $_[0]}++ }
+
+ package C2;
+ our @ISA = qw(C1);
+
+ # ---
+
+ package D;
+ sub DESTROY { $d{"D-" . ref $_[0]}++ }
+
+ package D1;
+ our @ISA = qw(D);
+
+ package main;
+
+ {
+ my @objs;
+ for my $class (qw(A A1 A2 B B1 B2 C C1 C2 D D1)) {
+ push @objs, bless [], $class;
+ }
+
+ sub f {
+ my $depth = shift;
+ my $cloned = ""; # XXX due to recursion, doesn't get initialized
+ $cloned .= "$_" =~ /ARRAY/ ? '1' : '0' for @objs;
+ is($cloned, ($depth ? '00010001111' : '11111111111'),
+ "objs clone skip at depth $depth");
+ threads->new( \&f, $depth+1)->join if $depth < 2;
+ @objs = ();
+ }
+ f(0);
+ }
+
+ curr_test(curr_test()+2);
+ ok(eq_hash(\%c,
+ {
+ qw(
+ A-A 2
+ A1-A1 2
+ A1-A2 2
+ B-B 2
+ B1-B1 2
+ B1-B2 2
+ C-C 2
+ C1-C1 2
+ C1-C2 2
+ )
+ }),
+ "counts of calls to CLONE_SKIP");
+ ok(eq_hash(\%d,
+ {
+ qw(
+ A-A 1
+ A1-A1 1
+ A1-A2 1
+ B-B 3
+ B1-B1 1
+ B1-B2 1
+ C-C 1
+ C1-C1 3
+ C1-C2 3
+ D-D 3
+ D-D1 3
+ )
+ }),
+ "counts of calls to DESTROY");
+}
==== //depot/perl/pod/perlmod.pod#36 (text) ====
@@ -539,7 +539,8 @@
module or by doing fork() on win32 (fake fork() support). When a
thread is cloned all Perl data is cloned, however non-Perl data cannot
be cloned automatically. Perl after 5.7.2 has support for the C<CLONE>
-special subroutine. In C<CLONE> you can do whatever you need to do,
+and C<CLONE_SKIP> special subroutines. In C<CLONE> you can do whatever
+you need to do,
like for example handle the cloning of non-Perl data, if necessary.
C<CLONE> will be called once as a class method for every package that has it
defined (or inherits it). It will be called in the context of the new thread,
@@ -551,6 +552,21 @@
If you want to CLONE all objects you will need to keep track of them per
package. This is simply done using a hash and Scalar::Util::weaken().
+Like C<CLONE>, C<CLONE_SKIP> is called once per package; however, it is
+called just before cloning starts, and in the context of the parent
+thread. If it returns a true value, then no objects of that class will
+be cloned; or rather, they will be copied as unblessed, undef values.
+This provides a simple mechanism for making a module threadsafe; just add
+C<sub CLONE_SKIP { 1 }> at the top of the class, and C<DESTROY()> will be
+now only be called once per object. Of course, if the child thread needs
+to make use of the objects, then a more sophisticated approach is
+needed.
+
+Like C<CLONE>, C<CLONE_SKIP> is currently called with no parameters other
+than the invocant package name, although that may change. Similarly, to
+allow for future expansion, the return value should be a single C<0> or
+C<1> value.
+
=head1 SEE ALSO
See L<perlmodlib> for general style issues related to building Perl
==== //depot/perl/sv.c#801 (text) ====
@@ -10775,6 +10775,13 @@
PL_watch_pvx, SvPVX(sstr));
#endif
+ /* don't clone objects whose class has asked us not to */
+ if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
+ SvFLAGS(dstr) &= ~SVTYPEMASK;
+ SvOBJECT_off(dstr);
+ return dstr;
+ }
+
switch (SvTYPE(sstr)) {
case SVt_NULL:
SvANY(dstr) = NULL;
@@ -11490,6 +11497,40 @@
return nss;
}
+
+/* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
+ * flag to the result. This is done for each stash before cloning starts,
+ * so we know which stashes want their objects cloned */
+
+static void
+do_mark_cloneable_stash(pTHX_ SV *sv)
+{
+ if (HvNAME((HV*)sv)) {
+ GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
+ SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
+ if (cloner && GvCV(cloner)) {
+ dSP;
+ UV status;
+
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVpv(HvNAME((HV*)sv), 0)));
+ PUTBACK;
+ call_sv((SV*)GvCV(cloner), G_SCALAR);
+ SPAGAIN;
+ status = POPu;
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ if (status)
+ SvFLAGS(sv) &= ~SVphv_CLONEABLE;
+ }
+ }
+}
+
+
+
/*
=for apidoc perl_clone
@@ -11571,6 +11612,8 @@
CLONE_PARAMS* param = &clone_params;
PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM,
sizeof(PerlInterpreter));
+ /* for each stash, determine whether its objects should be cloned */
+ S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
PERL_SET_THX(my_perl);
# ifdef DEBUGGING
@@ -11603,10 +11646,10 @@
CLONE_PARAMS clone_params;
CLONE_PARAMS* param = &clone_params;
PerlInterpreter *my_perl =
(PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
+ /* for each stash, determine whether its objects should be cloned */
+ S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
PERL_SET_THX(my_perl);
-
-
# ifdef DEBUGGING
Poison(my_perl, 1, PerlInterpreter);
PL_op = Nullop;
@@ -12314,7 +12357,7 @@
ENTER;
SAVETMPS;
PUSHMARK(SP);
- XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
+ XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
PUTBACK;
call_sv((SV*)GvCV(cloner), G_DISCARD);
FREETMPS;
==== //depot/perl/sv.h#174 (text) ====
@@ -221,6 +221,7 @@
#define SVrepl_EVAL 0x40000000 /* Replacement part of s///e */
+#define SVphv_CLONEABLE 0x08000000 /* for stashes: clone its
objects */
#define SVphv_REHASH 0x10000000 /* HV is recalculating hash values */
#define SVphv_SHAREKEYS 0x20000000 /* keys live on shared string table */
#define SVphv_LAZYDEL 0x40000000 /* entry in xhv_eiter must be deleted */
