Merge pull request #1 from Dual-Life/develop

1.51 Sync with blead

Author: Jerry D. Hedden

.gitignore

@@ -18,3 +18,7 @@ nytprof.out
 *.o
 *.bs
 /_eumm/
+
+/ARCHIVE/
+/stuff/
+/Notes.txt

Changes

@@ -1,8 +1,20 @@
 Revision history for Perl extension threads::shared.
 
 -
+	-
+
+1.51 Fri Apr 22 19:05:18 2016
+	- Documented that 'bless' does not propagate to nested shared items.
+
+1.48 Sat Jun 13 12:00:00 2015
 	- Fix for when freeing elements with $#shared = N to trigger shared object destruction
 
+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.43 Fri Jan 11 15:49:59 2013
 	- Timeout fix for t/stress.t (Nicholas Clark)
 
@@ -28,9 +40,6 @@ Revision history for Perl extension threads::shared.
 1.36 Fri Dec 24 16:50:11 2010
 	- POD update
 
-1.35 Mon Dec 20 15:09:01 2010
-	- Sync from blead (not released on CPAN)
-
 1.34 Fri Oct  8 16:48:25 2010
 	- Veto signal dispatch hook (commit 65c7421c80585e0d12a20773935dc01f4ffa3e42)
 

MANIFEST

@@ -30,5 +30,3 @@ t/wait.t
 t/waithires.t
 t/test.pl
 examples/class.pl
-META.yml                                 Module YAML meta-data (added by MakeMaker)
-META.json                                Module JSON meta-data (added by MakeMaker)

README

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

README.md

@@ -1,2 +1,5 @@
 # threads-shared
 The 'threads-shared' module for Perl.
+
+This module is dual-lived in both the core Perl distribution and on CPAN.
+

hints/linux.pl

@@ -7,7 +7,7 @@ use warnings;
 
 use Scalar::Util qw(reftype refaddr blessed);
 
-our $VERSION = '1.48'; # Please update the pod, too.
+our $VERSION = '1.51'; # 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.48
+This document describes threads::shared version 1.51
 
 =head1 SYNOPSIS
 
@@ -558,6 +558,17 @@ they contain will be lost.
 Therefore, populate such variables B<after> declaring them as shared.  (Scalar
 and scalar refs are not affected by this problem.)
 
+Blessing a shared item after it has been nested in another shared item does
+not propagate the blessing to the shared reference:
+
+  my $foo = &share({});
+  my $bar = &share({});
+  $bar->{foo} = $foo;
+  bless($foo, 'baz');   # $foo is now of class 'baz',
+                        # but $bar->{foo} is unblessed.
+
+Therefore, you should bless objects before sharing them.
+
 It is often not wise to share an object unless the class itself has been
 written to support sharing.  For example, an object's destructor may get
 called multiple times, once for each thread's scope exit.  Another danger is

lib/threads/shared.pm

@@ -179,22 +179,22 @@ typedef struct {
 
 static recursive_lock_t PL_sharedsv_lock;   /* Mutex protecting the shared sv space */
 
-void
+static void
 recursive_lock_init(pTHX_ recursive_lock_t *lock)
 {
     Zero(lock,1,recursive_lock_t);
     MUTEX_INIT(&lock->mutex);
     COND_INIT(&lock->cond);
 }
 
-void
+static void
 recursive_lock_destroy(pTHX_ recursive_lock_t *lock)
 {
     MUTEX_DESTROY(&lock->mutex);
     COND_DESTROY(&lock->cond);
 }
 
-void
+static void
 recursive_lock_release(pTHX_ recursive_lock_t *lock)
 {
     MUTEX_LOCK(&lock->mutex);
@@ -207,7 +207,7 @@ recursive_lock_release(pTHX_ recursive_lock_t *lock)
     MUTEX_UNLOCK(&lock->mutex);
 }
 
-void
+static void
 recursive_lock_acquire(pTHX_ recursive_lock_t *lock, const char *file, int line)
 {
     PERL_UNUSED_ARG(file);
@@ -276,7 +276,7 @@ typedef struct {
    we free the memory for the above.
  */
 
-int
+static int
 sharedsv_userlock_free(pTHX_ SV *sv, MAGIC *mg)
 {
     user_lock *ul = (user_lock *) mg->mg_ptr;
@@ -393,7 +393,7 @@ S_get_userlock(pTHX_ SV* ssv, bool create)
 /* Given a private side SV tries to find if the SV has a shared backend,
  * by looking for the magic.
  */
-SV *
+static SV *
 Perl_sharedsv_find(pTHX_ SV *sv)
 {
     MAGIC *mg;
@@ -429,7 +429,7 @@ Perl_sharedsv_find(pTHX_ SV *sv)
  * magics at it.
  * Assumes lock is held.
  */
-void
+static void
 Perl_sharedsv_associate(pTHX_ SV *sv, SV *ssv)
 {
     MAGIC *mg = 0;
@@ -548,7 +548,7 @@ S_sharedsv_dec(pTHX_ SV* ssv)
 
 /* Implements Perl-level share() and :shared */
 
-void
+static void
 Perl_sharedsv_share(pTHX_ SV *sv)
 {
     switch(SvTYPE(sv)) {
@@ -609,7 +609,7 @@ S_abs_2_rel_milli(double abs)
 
 /* Do OS-specific condition timed wait */
 
-bool
+static bool
 Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs)
 {
 #if defined(NETWARE) || defined(I_MACH_CTHREADS)
@@ -730,7 +730,7 @@ S_get_RV(pTHX_ SV *sv, SV *sobj) {
 
 /* Get magic for PERL_MAGIC_shared_scalar(n) */
 
-int
+static int
 sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg)
 {
     SV *ssv = (SV *) mg->mg_ptr;
@@ -750,7 +750,7 @@ sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg)
  * Used by various mg_set()-type functions.
  * Assumes lock is held.
  */
-void
+static void
 sharedsv_scalar_store(pTHX_ SV *sv, SV *ssv)
 {
     dTHXc;
@@ -809,7 +809,7 @@ sharedsv_scalar_store(pTHX_ SV *sv, SV *ssv)
 
 /* Set magic for PERL_MAGIC_shared_scalar(n) */
 
-int
+static int
 sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg)
 {
     SV *ssv = (SV*)(mg->mg_ptr);
@@ -828,7 +828,7 @@ sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg)
 
 /* Free magic for PERL_MAGIC_shared_scalar(n) */
 
-int
+static int
 sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg)
 {
     PERL_UNUSED_ARG(sv);
@@ -847,7 +847,7 @@ sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg)
 /*
  * Called during cloning of PERL_MAGIC_shared_scalar(n) magic in new thread
  */
-int
+static int
 sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
 {
     PERL_UNUSED_ARG(param);
@@ -859,7 +859,7 @@ sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
 /*
  * Called during local $shared
  */
-int
+static int
 sharedsv_scalar_mg_local(pTHX_ SV* nsv, MAGIC *mg)
 {
     MAGIC *nmg;
@@ -895,7 +895,7 @@ const MGVTBL sharedsv_scalar_vtbl = {
 
 /* Get magic for PERL_MAGIC_tiedelem(p) */
 
-int
+static int
 sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
 {
     dTHXc;
@@ -945,7 +945,7 @@ sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
 
 /* Set magic for PERL_MAGIC_tiedelem(p) */
 
-int
+static int
 sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
 {
     dTHXc;
@@ -988,7 +988,7 @@ sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
 
 /* Clear magic for PERL_MAGIC_tiedelem(p) */
 
-int
+static int
 sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
 {
     dTHXc;
@@ -1030,7 +1030,7 @@ sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
 /* Called during cloning of PERL_MAGIC_tiedelem(p) magic in new
  * thread */
 
-int
+static int
 sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
 {
     PERL_UNUSED_ARG(param);
@@ -1056,7 +1056,7 @@ const MGVTBL sharedsv_elem_vtbl = {
 
 /* Len magic for PERL_MAGIC_tied(P) */
 
-U32
+static U32
 sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg)
 {
     dTHXc;
@@ -1076,7 +1076,7 @@ sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg)
 
 /* Clear magic for PERL_MAGIC_tied(P) */
 
-int
+static int
 sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
 {
     dTHXc;
@@ -1110,7 +1110,7 @@ sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
 
 /* Free magic for PERL_MAGIC_tied(P) */
 
-int
+static int
 sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg)
 {
     PERL_UNUSED_ARG(sv);
@@ -1124,11 +1124,11 @@ sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg)
  * the array -
  */
 #if PERL_VERSION >= 11
-int
+static int
 sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
                        SV *nsv, const char *name, I32 namlen)
 #else
-int
+static int
 sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
                        SV *nsv, const char *name, int namlen)
 #endif
@@ -1143,7 +1143,7 @@ sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
 
 /* Called during cloning of PERL_MAGIC_tied(P) magic in new thread */
 
-int
+static int
 sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
 {
     PERL_UNUSED_ARG(param);
@@ -1166,21 +1166,10 @@ const MGVTBL sharedsv_array_vtbl = {
 };
 
 
-/* Recursively unlocks a shared sv. */
-
-void
-Perl_sharedsv_unlock(pTHX_ SV *ssv)
-{
-    user_lock *ul = S_get_userlock(aTHX_ ssv, 0);
-    assert(ul);
-    recursive_lock_release(aTHX_ &ul->lock);
-}
-
-
 /* Recursive locks on a sharedsv.
  * Locks are dynamically scoped at the level of the first lock.
  */
-void
+static void
 Perl_sharedsv_lock(pTHX_ SV *ssv)
 {
     user_lock *ul;
@@ -1192,7 +1181,7 @@ Perl_sharedsv_lock(pTHX_ SV *ssv)
 
 /* Handles calls from lock() builtin via PL_lockhook */
 
-void
+static void
 Perl_sharedsv_locksv(pTHX_ SV *sv)
 {
     SV *ssv;
@@ -1211,7 +1200,7 @@ Perl_sharedsv_locksv(pTHX_ SV *sv)
  * or if destroying last proxy on a shared object
  */
 #ifdef PL_destroyhook
-bool
+static bool
 Perl_shared_object_destroy(pTHX_ SV *sv)
 {
     SV *ssv;
@@ -1243,7 +1232,7 @@ S_shared_signal_hook(pTHX) {
 
 /* Saves a space for keeping SVs wider than an interpreter. */
 
-void
+static void
 Perl_sharedsv_init(pTHX)
 {
     dTHXc;

shared.xs

@@ -445,17 +445,22 @@ ($$$@)
     # We just accept like(..., qr/.../), not like(..., '...'), and
     # definitely not like(..., '/.../') like
     # Test::Builder::maybe_regex() does.
-    unless (ref($expected) &&  ref($expected) =~ /Regexp/) {
+    unless (re::is_regexp($expected)) {
 	die "PANIC: The value '$expected' isn't a regexp. The like() function needs a qr// pattern, not a string";
     }
 
     my $pass;
     $pass = $_[1] =~ /$expected/ if !$flip;
     $pass = $_[1] !~ /$expected/ if $flip;
+    my $display_got = $_[1];
+    $display_got = display($display_got);
+    my $display_expected = $expected;
+    $display_expected = display($display_expected);
     unless ($pass) {
-	unshift(@mess, "#      got '$_[1]'\n",
+	unshift(@mess, "#      got '$display_got'\n",
 		$flip
-		? "# expected !~ /$expected/\n" : "# expected /$expected/\n");
+		? "# expected !~ /$display_expected/\n"
+                : "# expected /$display_expected/\n");
     }
     local $Level = $Level + 1;
     _ok($pass, _where(), $name, @mess);