Support blessed shared references.

p4raw-id: //depot/perl@19715

diff --git a/ext/threads/shared/shared.pm b/ext/threads/shared/shared.pm
index c8d72e5..64ab079 100644 (file)
--- a/ext/threads/shared/shared.pm
+++ b/ext/threads/shared/shared.pm
@@ -3,24 +3,26 @@ package threads::shared;
 use 5.007_003;
 use strict;
 use warnings;
+BEGIN {
+    require Exporter;
+    our @ISA = qw(Exporter);
+    our @EXPORT = qw(share cond_wait cond_broadcast cond_signal);
+    our $VERSION = '0.90';
 
-require Exporter;
-our @ISA = qw(Exporter);
-our @EXPORT = qw(share cond_wait cond_broadcast cond_signal);
-our $VERSION = '0.90';
-
-if ($threads::threads) {
+    if ($threads::threads) {
        *cond_wait = \&cond_wait_enabled;
        *cond_signal = \&cond_signal_enabled;
        *cond_broadcast = \&cond_broadcast_enabled;
        require XSLoader;
        XSLoader::load('threads::shared',$VERSION);
-}
-else {
+       push @EXPORT,'bless';
+    }
+    else {
        *share = \&share_disabled;
        *cond_wait = \&cond_wait_disabled;
        *cond_signal = \&cond_signal_disabled;
        *cond_broadcast = \&cond_broadcast_disabled;
+    }
 }
 
 

diff --git a/ext/threads/shared/shared.xs b/ext/threads/shared/shared.xs
index 9e0f73b..8fe678d 100644 (file)
--- a/ext/threads/shared/shared.xs
+++ b/ext/threads/shared/shared.xs
@@ -329,6 +329,13 @@ Perl_sharedsv_associate(pTHX_ SV **psv, SV *ssv, shared_sv *data)
                mg->mg_flags |= (MGf_COPY|MGf_DUP);
                SvREFCNT_inc(ssv);
                SvREFCNT_dec(obj);
+               if(SvOBJECT(ssv)) {
+                 STRLEN len;
+                 char* stash_ptr = SvPV((SV*) SvSTASH(ssv), len);
+                 HV* stash = gv_stashpvn(stash_ptr, len, TRUE);
+                 SvOBJECT_on(sv);
+                 SvSTASH(sv) = (HV*)SvREFCNT_inc(stash);
+               }
            }
            break;
 
@@ -400,6 +407,7 @@ sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg)
            sv_setsv_nomg(sv, &PL_sv_undef);
            SvRV(sv) = obj;
            SvROK_on(sv);
+           
        }
        else {
            sv_setsv_nomg(sv, SHAREDSvPTR(shared));
@@ -422,6 +430,11 @@ sharedsv_scalar_store(pTHX_ SV *sv, shared_sv *shared)
            tmp = newRV(SHAREDSvPTR(target));
            sv_setsv_nomg(SHAREDSvPTR(shared), tmp);
            SvREFCNT_dec(tmp);
+           if(SvOBJECT(SvRV(sv))) {
+             SV* fake_stash = newSVpv(HvNAME(SvSTASH(SvRV(sv))),0);
+             SvOBJECT_on(SHAREDSvPTR(target));
+             SvSTASH(SHAREDSvPTR(target)) = (HV*)fake_stash;
+           }
            CALLER_CONTEXT;
        }
        else {
@@ -429,9 +442,14 @@ sharedsv_scalar_store(pTHX_ SV *sv, shared_sv *shared)
        }
     }
     else {
-               SvTEMP_off(sv);
+        SvTEMP_off(sv);
        SHARED_CONTEXT;
        sv_setsv_nomg(SHAREDSvPTR(shared), sv);
+       if(SvOBJECT(sv)) {
+         SV* fake_stash = newSVpv(HvNAME(SvSTASH(sv)),0);
+         SvOBJECT_on(SHAREDSvPTR(shared));
+         SvSTASH(SHAREDSvPTR(shared)) = (HV*)fake_stash;
+       }
        CALLER_CONTEXT;
     }
     if (!allowed) {
@@ -1059,6 +1077,48 @@ cond_broadcast_enabled(SV *ref)
                            "cond_broadcast() called on unlocked variable");
        COND_BROADCAST(&shared->user_cond);
 
+
+SV*
+bless(SV* ref, ...);
+       PROTOTYPE: $;$
+       CODE:
+        {
+         HV* stash;
+         shared_sv* shared;
+         if (items == 1)
+           stash = CopSTASH(PL_curcop);
+         else {
+           SV* ssv = ST(1);
+           STRLEN len;
+           char *ptr;
+           
+           if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
+             Perl_croak(aTHX_ "Attempt to bless into a reference");
+           ptr = SvPV(ssv,len);
+           if (ckWARN(WARN_MISC) && len == 0)
+             Perl_warner(aTHX_ packWARN(WARN_MISC),
+                         "Explicit blessing to '' (assuming package main)");
+           stash = gv_stashpvn(ptr, len, TRUE);
+         }
+         SvREFCNT_inc(ref);
+         (void)sv_bless(ref, stash);
+         RETVAL = ref;
+         shared = Perl_sharedsv_find(aTHX_ ref);
+         if(shared) {
+           dTHXc;
+           ENTER_LOCK;
+           SHARED_CONTEXT;
+           {
+             SV* fake_stash = newSVpv(HvNAME(stash),0);
+             (void)sv_bless(SHAREDSvPTR(shared),(HV*)fake_stash);
+           }
+           CALLER_CONTEXT;
+           LEAVE_LOCK;
+         }
+       }
+       OUTPUT:
+       RETVAL          
+
 #endif /* USE_ITHREADS */
 
 BOOT:

diff --git a/ext/threads/shared/t/hv_refs.t b/ext/threads/shared/t/hv_refs.t
index fb3c8de..66df0a6 100644 (file)
--- a/ext/threads/shared/t/hv_refs.t
+++ b/ext/threads/shared/t/hv_refs.t
@@ -30,7 +30,7 @@ sub skip {
 
 use ExtUtils::testlib;
 use strict;
-BEGIN { print "1..14\n" };
+BEGIN { print "1..17\n" };
 use threads;
 use threads::shared;
 ok(1,1,"loaded");
@@ -84,7 +84,15 @@ ok(10, keys %foo == 0, "And make sure we realy have deleted the values");
   ok(14, 1, "lock on helems now work, this was bug 10045");
 
 }
-
+{
+    my $object : shared = &share({});
+    threads->new(sub { bless $object, 'test1' });
+    ok(15, ref($object) eq 'test1', "blessing does work");
+    my %test = (object => $object);
+    ok(16, ref($test{object}) eq 'test1', "and some more work");
+    bless $object, 'test2';
+    ok(17, ref($test{object}) eq 'test2', "reblessing works!");
+}