threads-shared v1.48

Author: jdhedden

Changes

@@ -1,13 +1,7 @@
 Revision history for Perl extension threads::shared.
 
-1.46 Tue Feb  4 21:48:51 2014
-	- Sync from blead that fixes a thread context issue
-
-1.45 Wed Nov 13 15:27:09 2013
-	- Sync from blead
-
-1.44 Wed Nov 13 15:21:08 2013
-	- Sync from blead (not released on CPAN)
+-
+	- Fix for when freeing elements with $#shared = N to trigger shared object destruction
 
 1.43 Fri Jan 11 15:49:59 2013
 	- Timeout fix for t/stress.t (Nicholas Clark)

Makefile.PL

@@ -67,6 +67,7 @@ WriteMakefile(
         'Scalar::Util'      => 0,
         'threads'           => 1.73,
 
+        'Test'              => 0,
         'Test::More'        => 0,
         'ExtUtils::testlib' => 0,
     },

README

@@ -1,4 +1,4 @@
-threads::shared version 1.46
+threads::shared version 1.48
 ============================
 
 This module needs Perl 5.8.0 or later compiled with USEITHREADS.

lib/threads/shared.pm

@@ -7,7 +7,7 @@ use warnings;
 
 use Scalar::Util qw(reftype refaddr blessed);
 
-our $VERSION = '1.46'; # Please update the pod, too.
+our $VERSION = '1.48'; # Please update the pod, too.
 my $XS_VERSION = $VERSION;
 $VERSION = eval $VERSION;
 
@@ -195,7 +195,7 @@ threads::shared - Perl extension for sharing data structures between threads
 
 =head1 VERSION
 
-This document describes threads::shared version 1.46
+This document describes threads::shared version 1.48
 
 =head1 SYNOPSIS
 

shared.xs

@@ -136,7 +136,7 @@
 /*
  * The shared things need an interpreter to live in ...
  */
-PerlInterpreter *PL_sharedsv_space;             /* The shared sv space */
+static PerlInterpreter *PL_sharedsv_space;             /* The shared sv space */
 /* To access shared space we fake aTHX in this scope and thread's context */
 
 /* Bug #24255: We include ENTER+SAVETMPS/FREETMPS+LEAVE with
@@ -177,7 +177,7 @@ typedef struct {
 #endif
 } recursive_lock_t;
 
-recursive_lock_t PL_sharedsv_lock;   /* Mutex protecting the shared sv space */
+static recursive_lock_t PL_sharedsv_lock;   /* Mutex protecting the shared sv space */
 
 void
 recursive_lock_init(pTHX_ recursive_lock_t *lock)
@@ -291,7 +291,7 @@ sharedsv_userlock_free(pTHX_ SV *sv, MAGIC *mg)
     return (0);
 }
 
-MGVTBL sharedsv_userlock_vtbl = {
+static const MGVTBL sharedsv_userlock_vtbl = {
     0,                          /* get */
     0,                          /* set */
     0,                          /* len */
@@ -332,10 +332,10 @@ MGVTBL sharedsv_userlock_vtbl = {
    the shared thing.
  */
 
-extern MGVTBL sharedsv_scalar_vtbl;    /* Scalars have this vtable */
-extern MGVTBL sharedsv_array_vtbl;     /* Hashes and arrays have this
+extern const MGVTBL sharedsv_scalar_vtbl;   /* Scalars have this vtable */
+extern const MGVTBL sharedsv_array_vtbl;     /* Hashes and arrays have this
                                             - like 'tie' */
-extern MGVTBL sharedsv_elem_vtbl;      /* Elements of hashes and arrays have
+extern const MGVTBL sharedsv_elem_vtbl;      /* Elements of hashes and arrays have
                                           this _AS WELL AS_ the scalar magic:
    The sharedsv_elem_vtbl associates the element with the array/hash and
    the sharedsv_scalar_vtbl associates it with the value
@@ -878,7 +878,7 @@ sharedsv_scalar_mg_local(pTHX_ SV* nsv, MAGIC *mg)
 }
 #endif
 
-MGVTBL sharedsv_scalar_vtbl = {
+const MGVTBL sharedsv_scalar_vtbl = {
     sharedsv_scalar_mg_get,     /* get */
     sharedsv_scalar_mg_set,     /* set */
     0,                          /* len */
@@ -1039,7 +1039,7 @@ sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
     return (0);
 }
 
-MGVTBL sharedsv_elem_vtbl = {
+const MGVTBL sharedsv_elem_vtbl = {
     sharedsv_elem_mg_FETCH,     /* get */
     sharedsv_elem_mg_STORE,     /* set */
     0,                          /* len */
@@ -1152,7 +1152,7 @@ sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
     return (0);
 }
 
-MGVTBL sharedsv_array_vtbl = {
+const MGVTBL sharedsv_array_vtbl = {
     0,                          /* get */
     0,                          /* set */
     sharedsv_array_mg_FETCHSIZE,/* len */
@@ -1371,9 +1371,29 @@ void
 STORESIZE(SV *obj,IV count)
     CODE:
         dTHXc;
-        SV *sobj = SHAREDSV_FROM_OBJ(obj);
+        SV *ssv = SHAREDSV_FROM_OBJ(obj);
+
         SHARED_EDIT;
-        av_fill((AV*) sobj, count);
+        assert(SvTYPE(ssv) == SVt_PVAV);
+        if (!PL_dirty) {
+            SV **svp = AvARRAY((AV *)ssv);
+            I32 ix = AvFILLp((AV *)ssv);
+            for (;ix >= count; ix--) {
+                SV *sv = svp[ix];
+                if (!sv)
+                    continue;
+                if (   (SvOBJECT(sv) || (SvROK(sv) && (sv = SvRV(sv))))
+                    && SvREFCNT(sv) == 1 )
+                {
+                    SV *tmp = Perl_sv_newmortal(caller_perl);
+                    PERL_SET_CONTEXT((aTHX = caller_perl));
+                    sv_upgrade(tmp, SVt_RV);
+                    get_RV(tmp, sv);
+                    PERL_SET_CONTEXT((aTHX = PL_sharedsv_space));
+                }
+            }
+        }
+        av_fill((AV*) ssv, count - 1);
         SHARED_RELEASE;
 
 

t/av_simple.t

@@ -27,7 +27,7 @@ sub ok {
 
 BEGIN {
     $| = 1;
-    print("1..44\n");   ### Number of tests that will be run ###
+    print("1..47\n");   ### Number of tests that will be run ###
 };
 
 use threads;
@@ -130,6 +130,16 @@ ok(37, !defined delete($foo[0]), "Check that delete works from a thread");
 
 ok(44, is_shared(@foo), "Check for sharing");
 
+# RT #122950
+
+@foo = ('a'..'z');
+$#foo = 2;
+
+ok(45, $#foo == 2,        "\$#foo assignment: \$#");
+ok(46, @foo  == 3,        "\$#foo assignment: scalar");
+ok(47, "@foo" eq "a b c", "\$#foo assignment: array interpolation");
+
+
 exit(0);
 
 # EOF

t/hv_refs.t

@@ -63,7 +63,7 @@ ok(8, threads::shared::_id($$gg) == threads::shared::_id($$gg2),
        sprintf("Check we get the same thing (%x vs %x)",
        threads::shared::_id($$gg),threads::shared::_id($$gg2)));
 ok(9, $$gg eq $$gg2, "And check the values are the same");
-ok(10, keys %foo == 0, "And make sure we realy have deleted the values");
+ok(10, keys %foo == 0, "And make sure we really have deleted the values");
 {
     my (%hash1, %hash2);
     share(%hash1);

t/object2.t

@@ -17,7 +17,7 @@ use ExtUtils::testlib;
 
 BEGIN {
     $| = 1;
-    print("1..122\n");   ### Number of tests that will be run ###
+    print("1..131\n");   ### Number of tests that will be run ###
 };
 
 use threads;
@@ -406,4 +406,45 @@ ok($destroyed[$ID], 'Scalar object removed from undef shared hash');
 }
 ok($destroyed[$ID], 'Scalar object removed from shared scalar');
 
+#
+# RT #122950 abandoning array elements (e.g. by setting $#ary)
+# should trigger destructors
+
+{
+    package rt122950;
+
+    my $count = 0;
+    sub DESTROY { $count++ }
+
+    my $n = 4;
+
+    for my $type (0..1) {
+        my @a : shared;
+        $count = 0;
+        push @a, bless &threads::shared::share({}) for 1..$n;
+        for (1..$n) {
+            { # new scope to ensure tmps are freed, destructors called
+                if ($type) {
+                    pop @a;
+                }
+                else {
+                    $#a = $n - $_ - 1;
+                }
+            }
+            ::ok($count == $_,
+                "remove array object $_ by " . ($type ? "pop" : '$#a=N'));
+        }
+    }
+
+    my @a : shared;
+    $count = 0;
+    push @a, bless &threads::shared::share({}) for 1..$n;
+    {
+        undef @a; # this is implemented internally as $#a = -01
+    }
+    ::ok($count == $n, "remove array object by undef");
+}
+
+
+
 # EOF