Upgrade to threads::shared 1.42

2 files changed, 428 insertions, 68 deletions

diff --git a/dist/threads-shared/shared.xs b/dist/threads-shared/shared.xs
index 5da9a55938..909643cea0 100644
--- a/dist/threads-shared/shared.xs
+++ b/dist/threads-shared/shared.xs
@@ -329,7 +329,28 @@ extern MGVTBL sharedsv_elem_vtbl;      /* Elements of hashes and arrays have
 STATIC SV *
 S_sharedsv_from_obj(pTHX_ SV *sv)
 {
-     return ((SvROK(sv)) ? INT2PTR(SV *, SvIV(SvRV(sv))) : NULL);
+    return ((SvROK(sv)) ? INT2PTR(SV *, SvIV(SvRV(sv))) : NULL);
+}
+
+
+/* Return SV flags associated with dual-valued variables */
+U32
+S_get_dualvar_flags(pTHX_ SV *sv)
+{
+    if (SvPOK(sv) && (SvNIOK(sv) || SvNIOKp(sv))) {
+        if (SvNOK(sv) || SvNOKp(sv)) {
+            return SVf_NOK;
+        }
+#ifdef SVf_IVisUV
+        if (SvIsUV(sv)) {
+            return (SVf_IOK | SVf_IVisUV);
+        }
+#endif
+        if (SvIOK(sv) || SvIOKp(sv)) {
+            return SVf_IOK;
+        }
+    }
+    return 0;
 }
 
 
@@ -937,7 +958,8 @@ sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
     dTHXc;
     SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj);
     SV **svp;
-    U32 dualvar_flags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK);
+    U32 dualvar_flags;
+
     /* Theory - SV itself is magically shared - and we have ordered the
        magic such that by the time we get here it has been stored
        to its shared counterpart
@@ -964,12 +986,10 @@ sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
         svp = hv_fetch((HV*) saggregate, key, len, 1);
     }
     CALLER_CONTEXT;
+    dualvar_flags = S_get_dualvar_flags(aTHX_ sv);
     Perl_sharedsv_associate(aTHX_ sv, *svp);
     sharedsv_scalar_store(aTHX_ sv, *svp);
-    /* Propagate dualvar flags */
-    if (SvPOK(*svp)) {
-        SvFLAGS(*svp) |= dualvar_flags;
-    }
+    SvFLAGS(*svp) |= dualvar_flags;
     LEAVE_LOCK;
     return (0);
 }
@@ -1189,7 +1209,7 @@ Perl_sharedsv_locksv(pTHX_ SV *sv)
         sv = SvRV(sv);
     ssv = Perl_sharedsv_find(aTHX_ sv);
     if (!ssv)
-       croak("lock can only be used on shared values");
+        croak("lock can only be used on shared values");
     Perl_sharedsv_lock(aTHX_ ssv);
 }
 
@@ -1224,7 +1244,7 @@ S_shared_signal_hook(pTHX) {
     us = (PL_sharedsv_lock.owner == aTHX);
     MUTEX_UNLOCK(&PL_sharedsv_lock.mutex);
     if (us)
-	return; /* try again later */
+        return; /* try again later */
     prev_signal_hook(aTHX);
 }
 #endif
@@ -1248,8 +1268,8 @@ Perl_sharedsv_init(pTHX)
 #endif
 #ifdef PL_signalhook
     if (!prev_signal_hook) {
-	prev_signal_hook = PL_signalhook;
-	PL_signalhook = &S_shared_signal_hook;
+        prev_signal_hook = PL_signalhook;
+        PL_signalhook = &S_shared_signal_hook;
     }
 #endif
 }
@@ -1267,13 +1287,15 @@ PUSH(SV *obj, ...)
     CODE:
         dTHXc;
         SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
-        int i;
-        for (i = 1; i < items; i++) {
-            SV* tmp = newSVsv(ST(i));
+        int ii;
+        for (ii = 1; ii < items; ii++) {
+            SV* tmp = newSVsv(ST(ii));
             SV *stmp;
+            U32 dualvar_flags = S_get_dualvar_flags(aTHX_ tmp);
             ENTER_LOCK;
             stmp = S_sharedsv_new_shared(aTHX_ tmp);
             sharedsv_scalar_store(aTHX_ tmp, stmp);
+            SvFLAGS(stmp) |= dualvar_flags;
             SHARED_CONTEXT;
             av_push((AV*) sobj, stmp);
             SvREFCNT_inc_void(stmp);
@@ -1287,17 +1309,19 @@ UNSHIFT(SV *obj, ...)
     CODE:
         dTHXc;
         SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
-        int i;
+        int ii;
         ENTER_LOCK;
         SHARED_CONTEXT;
         av_unshift((AV*)sobj, items - 1);
         CALLER_CONTEXT;
-        for (i = 1; i < items; i++) {
-            SV *tmp = newSVsv(ST(i));
+        for (ii = 1; ii < items; ii++) {
+            SV *tmp = newSVsv(ST(ii));
+            U32 dualvar_flags = S_get_dualvar_flags(aTHX_ tmp);
             SV *stmp = S_sharedsv_new_shared(aTHX_ tmp);
             sharedsv_scalar_store(aTHX_ tmp, stmp);
             SHARED_CONTEXT;
-            av_store((AV*) sobj, i - 1, stmp);
+            SvFLAGS(stmp) |= dualvar_flags;
+            av_store((AV*) sobj, ii - 1, stmp);
             SvREFCNT_inc_void(stmp);
             CALLER_CONTEXT;
             SvREFCNT_dec(tmp);
@@ -1647,7 +1671,7 @@ cond_broadcast(SV *myref)
 
 
 void
-bless(SV* myref, ...);
+bless(SV* myref, ...)
     PROTOTYPE: $;$
     PREINIT:
         HV* stash;
diff --git a/dist/threads-shared/t/dualvar.t b/dist/threads-shared/t/dualvar.t
index ef6fc177b5..11d2cf46f3 100644
--- a/dist/threads-shared/t/dualvar.t
+++ b/dist/threads-shared/t/dualvar.t
@@ -11,83 +11,419 @@ BEGIN {
 
 use ExtUtils::testlib;
 
+BEGIN {
+    $| = 1;
+    print("1..219\n");    ### Number of tests that will be run ###
+}
+
+use threads;
+use threads::shared;
+use Scalar::Util qw(dualvar);
+
+my $TEST = 1;
+
 sub ok {
-    my ($id, $ok, $name) = @_;
+    my ($ok, $name) = @_;
 
     # You have to do it this way or VMS will get confused.
     if ($ok) {
-        print("ok $id - $name\n");
-    }
-    else {
-        print("not ok $id - $name\n");
-        printf("# Failed test at line %d\n", (caller)[2]);
+        print("ok $TEST - $name\n");
+    } else {
+        print("not ok $TEST - $name\n");
+        printf("# Failed test at line %d\n", (caller(1))[2]);
     }
 
-    return ($ok);
+    $TEST++;
 }
 
-BEGIN {
-    $| = 1;
-    print("1..19\n");    ### Number of tests that will be run ###
+sub ok_iv
+{
+    my ($var, $iv) = @_;
+    ok($var == $iv, 'IV number preserved');
+    ok($var eq $iv, 'String preserved');
 }
 
-use Scalar::Util qw(dualvar);
-
-use threads;
-use threads::shared;
+sub ok_nv
+{
+    my ($var, $nv) = @_;
+    ok($var == $nv, 'NV number preserved');
+    ok($var eq $nv, 'String preserved');
+}
 
-ok(1, 1, 'Loaded');
+sub ok_uv
+{
+    my ($var, $uv) = @_;
+    ok($var == $uv, 'UV number preserved');
+    ok($var > 0, 'UV number preserved');
+    ok($var eq $uv, 'String preserved');
+}
 
 ### Start of Testing ###
 
-my $dv = dualvar(42, 'Fourty-Two');
-my $pi = dualvar(3.14, 'PI');
+my $iv = dualvar(42, 'Fourty-Two');
+my $nv = dualvar(3.14, 'PI');
+my $bits = ($Config{'use64bitint'}) ? 63 : 31;
+my $uv = dualvar(1<<$bits, 'Large unsigned int');
+
+print("# Shared scalar assignment using shared_clone()\n");
+
+my $siv :shared = shared_clone($iv);
+my $snv :shared = shared_clone($nv);
+my $suv :shared = shared_clone($uv);
+
+ok_iv($siv, $iv);
+ok_nv($snv, $nv);
+ok_uv($suv, $uv);
+
+{
+    print("# Shared array initialization\n");
+
+    my @ary :shared = ($iv, $nv, $uv);
+
+    ok_iv($ary[0], $iv);
+    ok_nv($ary[1], $nv);
+    ok_uv($ary[2], $uv);
+}
+
+{
+    print("# Shared array list assignment\n");
+
+    my @ary :shared;
+    @ary = ($iv, $nv, $uv);
+
+    ok_iv($ary[0], $iv);
+    ok_nv($ary[1], $nv);
+    ok_uv($ary[2], $uv);
+}
+
+{
+    print("# Shared array element assignment\n");
+
+    my @ary :shared;
+    $ary[0] = $iv;
+    $ary[1] = $nv;
+    $ary[2] = $uv;
+
+    ok_iv($ary[0], $iv);
+    ok_nv($ary[1], $nv);
+    ok_uv($ary[2], $uv);
+}
+
+{
+    print("# Shared array initialization - shared scalars\n");
+
+    my @ary :shared = ($siv, $snv, $suv);
+
+    ok_iv($ary[0], $iv);
+    ok_nv($ary[1], $nv);
+    ok_uv($ary[2], $uv);
+}
+
+{
+    print("# Shared array list assignment - shared scalars\n");
+
+    my @ary :shared;
+    @ary = ($siv, $snv, $suv);
+
+    ok_iv($ary[0], $iv);
+    ok_nv($ary[1], $nv);
+    ok_uv($ary[2], $uv);
+}
+
+{
+    print("# Shared array element assignment - shared scalars\n");
+
+    # FAILS
+
+    my @ary :shared;
+    $ary[0] = $siv;
+    $ary[1] = $snv;
+    $ary[2] = $suv;
+
+    ok_iv($ary[0], $iv);
+    ok_nv($ary[1], $nv);
+    ok_uv($ary[2], $uv);
+}
+
+{
+    print("# Shared hash initialization\n");
+
+    my %hsh :shared = (
+        'iv' => $iv,
+        'nv' => $nv,
+        'uv' => $uv,
+    );
+
+    ok_iv($hsh{'iv'}, $iv);
+    ok_nv($hsh{'nv'}, $nv);
+    ok_uv($hsh{'uv'}, $uv);
+}
+
+{
+    print("# Shared hash assignment\n");
+
+    my %hsh :shared;
+    %hsh = (
+        'iv' => $iv,
+        'nv' => $nv,
+        'uv' => $uv,
+    );
+
+    ok_iv($hsh{'iv'}, $iv);
+    ok_nv($hsh{'nv'}, $nv);
+    ok_uv($hsh{'uv'}, $uv);
+}
+
+{
+    print("# Shared hash element assignment\n");
+
+    my %hsh :shared;
+    $hsh{'iv'} = $iv;
+    $hsh{'nv'} = $nv;
+    $hsh{'uv'} = $uv;
+
+    ok_iv($hsh{'iv'}, $iv);
+    ok_nv($hsh{'nv'}, $nv);
+    ok_uv($hsh{'uv'}, $uv);
+}
+
+{
+    print("# Shared hash initialization - shared scalars\n");
+
+    my %hsh :shared = (
+        'iv' => $siv,
+        'nv' => $snv,
+        'uv' => $suv,
+    );
+
+    ok_iv($hsh{'iv'}, $iv);
+    ok_nv($hsh{'nv'}, $nv);
+    ok_uv($hsh{'uv'}, $uv);
+}
+
+{
+    print("# Shared hash assignment - shared scalars\n");
+
+    my %hsh :shared;
+    %hsh = (
+        'iv' => $siv,
+        'nv' => $snv,
+        'uv' => $suv,
+    );
+
+    ok_iv($hsh{'iv'}, $iv);
+    ok_nv($hsh{'nv'}, $nv);
+    ok_uv($hsh{'uv'}, $uv);
+}
+
+{
+    print("# Shared hash element assignment - shared scalars\n");
+
+    my %hsh :shared;
+    $hsh{'iv'} = $siv;
+    $hsh{'nv'} = $snv;
+    $hsh{'uv'} = $suv;
+
+    ok_iv($hsh{'iv'}, $iv);
+    ok_nv($hsh{'nv'}, $nv);
+    ok_uv($hsh{'uv'}, $uv);
+}
+
+{
+    print("# Shared array push\n");
+
+    my @ary :shared;
+    push(@ary, $iv, $nv, $uv);
+
+    ok_iv($ary[0], $iv);
+    ok_nv($ary[1], $nv);
+    ok_uv($ary[2], $uv);
+
+    print("# Shared array pop\n");
+
+    my $xuv = pop(@ary);
+    my $xnv = pop(@ary);
+    my $xiv = pop(@ary);
+
+    ok_iv($xiv, $iv);
+    ok_nv($xnv, $nv);
+    ok_uv($xuv, $uv);
+
+    print("# Shared array unshift\n");
+
+    unshift(@ary, $iv, $nv, $uv);
+
+    ok_iv($ary[0], $iv);
+    ok_nv($ary[1], $nv);
+    ok_uv($ary[2], $uv);
+
+    print("# Shared array shift\n");
+
+    $xiv = shift(@ary);
+    $xnv = shift(@ary);
+    $xuv = shift(@ary);
+
+    ok_iv($xiv, $iv);
+    ok_nv($xnv, $nv);
+    ok_uv($xuv, $uv);
+}
+
+{
+    print("# Shared array push - shared scalars\n");
+
+    my @ary :shared;
+    push(@ary, $siv, $snv, $suv);
+
+    ok_iv($ary[0], $iv);
+    ok_nv($ary[1], $nv);
+    ok_uv($ary[2], $uv);
+
+    print("# Shared array pop - shared scalars\n");
+
+    my $xuv = pop(@ary);
+    my $xnv = pop(@ary);
+    my $xiv = pop(@ary);
+
+    ok_iv($xiv, $iv);
+    ok_nv($xnv, $nv);
+    ok_uv($xuv, $uv);
+
+    print("# Shared array unshift - shared scalars\n");
+
+    unshift(@ary, $siv, $snv, $suv);
+
+    ok_iv($ary[0], $iv);
+    ok_nv($ary[1], $nv);
+    ok_uv($ary[2], $uv);
+
+    print("# Shared array shift - shared scalars\n");
 
-my @a :shared;
+    $xiv = shift(@ary);
+    $xnv = shift(@ary);
+    $xuv = shift(@ary);
 
-# Individual assignment
-# Verify that dualvar preserved during individual element assignment
-$a[0] = $dv;
-$a[1] = $pi;
+    ok_iv($xiv, $iv);
+    ok_nv($xnv, $nv);
+    ok_uv($xuv, $uv);
+}
+
+{
+    print("# Shared hash delete\n");
+
+    my %hsh :shared = (
+        'iv' => $iv,
+        'nv' => $nv,
+        'uv' => $uv,
+    );
+
+    ok_iv(delete($hsh{'iv'}), $iv);
+    ok_nv(delete($hsh{'nv'}), $nv);
+    ok_uv(delete($hsh{'uv'}), $uv);
+}
+
+{
+    print("# Shared hash delete - shared scalars\n");
+
+    my %hsh :shared = (
+        'iv' => $siv,
+        'nv' => $snv,
+        'uv' => $suv,
+    );
+
+    ok_iv(delete($hsh{'iv'}), $iv);
+    ok_nv(delete($hsh{'nv'}), $nv);
+    ok_uv(delete($hsh{'uv'}), $uv);
+}
+
+{
+    print("# Shared array copy to non-shared array\n");
+
+    my @ary :shared = ($iv, $nv, $uv);
+    my @nsa = @ary;
+
+    ok_iv($nsa[0], $iv);
+    ok_nv($nsa[1], $nv);
+    ok_uv($nsa[2], $uv);
+
+    print("# Shared array copy using shared_clone()\n");
+
+    my $copy :shared = shared_clone(\@nsa);
+
+    ok_iv($$copy[0], $iv);
+    ok_nv($$copy[1], $nv);
+    ok_uv($$copy[2], $uv);
+}
 
-ok(2, $a[0] == 42, 'IV number preserved');
-ok(3, $a[0] eq 'Fourty-Two', 'string preserved');
-ok(4, $a[1] == 3.14, 'NV number preserved');
-ok(5, $a[1] eq 'PI', 'string preserved');
+{
+    print("# Shared array copy to non-shared array - shared scalars\n");
 
-#-- List initializer
-# Verify that dualvar preserved during initialization
-my @a2 :shared = ($dv, $pi);
+    my @ary :shared = ($siv, $snv, $suv);
+    my @nsa = @ary;
 
-ok(6, $a2[0] == 42, 'IV number preserved');
-ok(7, $a2[0] eq 'Fourty-Two', 'string preserved');
-ok(8, $a2[1] == 3.14, 'NV number preserved');
-ok(9, $a2[1] eq 'PI', 'string preserved');
+    ok_iv($nsa[0], $iv);
+    ok_nv($nsa[1], $nv);
+    ok_uv($nsa[2], $uv);
 
-#-- List assignment
-# Verify that dualvar preserved during list assignment
-my @a3 :shared = (0, 0);
-@a3 = ($dv, $pi);
+    print("# Shared array copy using shared_clone()\n");
 
-ok(10, $a3[0] == 42, 'IV number preserved');
-ok(11, $a3[0] eq 'Fourty-Two', 'string preserved');
-ok(12, $a3[1] == 3.14, 'NV number preserved');
-ok(13, $a3[1] eq 'PI', 'string preserved');
+    my $copy :shared = shared_clone(\@nsa);
 
-# Back to non-shared
-# Verify that entries are still dualvar when leaving the array
-my @nsa = @a3;
-ok(14, $nsa[0] == 42, 'IV number preserved');
-ok(15, $nsa[0] eq 'Fourty-Two', 'string preserved');
-ok(16, $nsa[1] == 3.14, 'NV number preserved');
-ok(17, $nsa[1] eq 'PI', 'string preserved');
+    ok_iv($$copy[0], $iv);
+    ok_nv($$copy[1], $nv);
+    ok_uv($$copy[2], $uv);
+}
+
+{
+    print("# Shared hash copy to non-shared hash\n");
+
+    my %hsh :shared = (
+        'iv' => $iv,
+        'nv' => $nv,
+        'uv' => $uv,
+    );
+    my %nsh = %hsh;
+
+    ok_iv($nsh{'iv'}, $iv);
+    ok_nv($nsh{'nv'}, $nv);
+    ok_uv($nsh{'uv'}, $uv);
+
+    print("# Shared hash copy using shared_clone()\n");
+
+    my $copy :shared = shared_clone(\%nsh);
+
+    ok_iv($$copy{'iv'}, $iv);
+    ok_nv($$copy{'nv'}, $nv);
+    ok_uv($$copy{'uv'}, $uv);
+}
+
+{
+    print("# Shared hash copy to non-shared hash - shared scalars\n");
+
+    my %hsh :shared = (
+        'iv' => $siv,
+        'nv' => $snv,
+        'uv' => $suv,
+    );
+    my %nsh = %hsh;
+
+    ok_iv($nsh{'iv'}, $iv);
+    ok_nv($nsh{'nv'}, $nv);
+    ok_uv($nsh{'uv'}, $uv);
+
+    print("# Shared hash copy using shared_clone()\n");
+
+    my $copy :shared = shared_clone(\%nsh);
+
+    ok_iv($$copy{'iv'}, $iv);
+    ok_nv($$copy{'nv'}, $nv);
+    ok_uv($$copy{'uv'}, $uv);
+}
 
 # $! behaves like a dualvar, but is really implemented as a tied SV.
 # As a result sharing $! directly only propagates the string value.
 # However, we can create a dualvar from it.
 $! = 1;
 my $ss :shared = dualvar($!,$!);
-ok(18, $ss == 1, 'IV number preserved');
-ok(19, $ss eq $!, 'string preserved');
+ok_iv($ss, $!);
 
 exit(0);