threads::shared 1.24

From: "Jerry D. Hedden" <jdhedden@cpan.org>
Message-ID: <1ff86f510807020701v78a14d06g1e0e5f098c6131ed@mail.gmail.com>

...plus some adjustments to the test headers to prevent failures
in the Perl core.

p4raw-id: //depot/perl@34098

5 files changed, 137 insertions, 73 deletions

diff --git a/ext/threads/shared/shared.pm b/ext/threads/shared/shared.pm
index c73303b71d..f25f16602e 100644
--- a/ext/threads/shared/shared.pm
+++ b/ext/threads/shared/shared.pm
@@ -7,7 +7,7 @@ use warnings;
 
 use Scalar::Util qw(reftype refaddr blessed);
 
-our $VERSION = '1.23';
+our $VERSION = '1.24';
 my $XS_VERSION = $VERSION;
 $VERSION = eval $VERSION;
 
@@ -186,7 +186,7 @@ threads::shared - Perl extension for sharing data structures between threads
 
 =head1 VERSION
 
-This document describes threads::shared version 1.23
+This document describes threads::shared version 1.24
 
 =head1 SYNOPSIS
 
@@ -540,7 +540,7 @@ L<threads::shared> Discussion Forum on CPAN:
 L<http://www.cpanforum.com/dist/threads-shared>
 
 Annotated POD for L<threads::shared>:
-L<http://annocpan.org/~JDHEDDEN/threads-shared-1.23/shared.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-shared-1.24/shared.pm>
 
 Source repository:
 L<http://code.google.com/p/threads-shared/>
diff --git a/ext/threads/shared/shared.xs b/ext/threads/shared/shared.xs
index cdea8c9c49..b7447964a2 100644
--- a/ext/threads/shared/shared.xs
+++ b/ext/threads/shared/shared.xs
@@ -123,6 +123,7 @@
 #  define NEED_sv_2pv_flags
 #  define NEED_vnewSVpvf
 #  define NEED_warner
+#  define NEED_newSVpvn_flags
 #  include "ppport.h"
 #  include "shared.h"
 #endif
@@ -875,7 +876,7 @@ sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
         STRLEN len = mg->mg_len;
         assert ( mg->mg_ptr != 0 );
         if (mg->mg_len == HEf_SVKEY) {
-           key = SvPV((SV *) mg->mg_ptr, len);
+           key = SvPVutf8((SV *)mg->mg_ptr, len);
         }
         SHARED_CONTEXT;
         svp = hv_fetch((HV*) saggregate, key, len, 0);
@@ -926,7 +927,7 @@ sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
         STRLEN len = mg->mg_len;
         assert ( mg->mg_ptr != 0 );
         if (mg->mg_len == HEf_SVKEY)
-           key = SvPV((SV *) mg->mg_ptr, len);
+           key = SvPVutf8((SV *)mg->mg_ptr, len);
         SHARED_CONTEXT;
         svp = hv_fetch((HV*) saggregate, key, len, 1);
     }
@@ -957,7 +958,7 @@ sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
         STRLEN len = mg->mg_len;
         assert ( mg->mg_ptr != 0 );
         if (mg->mg_len == HEf_SVKEY)
-           key = SvPV((SV *) mg->mg_ptr, len);
+           key = SvPVutf8((SV *)mg->mg_ptr, len);
         SHARED_CONTEXT;
         hv_delete((HV*) saggregate, key, len, G_DISCARD);
     }
@@ -1275,7 +1276,7 @@ EXISTS(SV *obj, SV *index)
             exists = av_exists((AV*) sobj, SvIV(index));
         } else {
             STRLEN len;
-            char *key = SvPV(index,len);
+            char *key = SvPVutf8(index, len);
             SHARED_EDIT;
             exists = hv_exists((HV*) sobj, key, len);
         }
@@ -1299,7 +1300,7 @@ FIRSTKEY(SV *obj)
         if (entry) {
             key = hv_iterkey(entry,&len);
             CALLER_CONTEXT;
-            ST(0) = sv_2mortal(newSVpv(key, len));
+            ST(0) = sv_2mortal(newSVpvn_utf8(key, len, 1));
         } else {
             CALLER_CONTEXT;
             ST(0) = &PL_sv_undef;
@@ -1325,7 +1326,7 @@ NEXTKEY(SV *obj, SV *oldkey)
         if (entry) {
             key = hv_iterkey(entry,&len);
             CALLER_CONTEXT;
-            ST(0) = sv_2mortal(newSVpv(key, len));
+            ST(0) = sv_2mortal(newSVpvn_utf8(key, len, 1));
         } else {
             CALLER_CONTEXT;
             ST(0) = &PL_sv_undef;
diff --git a/ext/threads/shared/t/utf8.t b/ext/threads/shared/t/utf8.t
new file mode 100644
index 0000000000..f2e0ac3c77
--- /dev/null
+++ b/ext/threads/shared/t/utf8.t
@@ -0,0 +1,95 @@
+use strict;
+use warnings;
+
+BEGIN {
+    if ($ENV{'PERL_CORE'}){
+        chdir 't';
+        unshift @INC, '../lib';
+    }
+    use Config;
+    if (! $Config{'useithreads'}) {
+        print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+        exit(0);
+    }
+}
+
+use ExtUtils::testlib;
+
+my $TEST = 1;
+
+sub is {
+    my ($got, $exp, $name) = @_;
+
+    my $ok = ($got eq $exp);
+
+    # You have to do it this way or VMS will get confused.
+    if ($ok) {
+        print("ok $TEST - $name\n");
+    } else {
+        print("not ok $TEST - $name\n");
+        printf("# Failed test at line %d\n", (caller)[2]);
+        print("#   Got:      $got\n");
+        print("#   Expected: $exp\n");
+    }
+
+    $TEST++;
+
+    return ($ok);
+}
+
+BEGIN {
+    $| = 1;
+    print("1..12\n");   ### Number of tests that will be run ###
+};
+
+use threads;
+use threads::shared;
+
+### Start of Testing ###
+
+binmode STDOUT, ":utf8";
+
+my $plain = 'foo';
+my $utf8 = "\x{123}\x{84}\x{20F}\x{2C1}";
+
+my %a :shared;
+$a{$plain} = $plain;
+$a{$utf8} = $utf8;
+$a{\&is} = 'code';
+
+is(exists($a{$plain}), 1, 'Found plain key in shared hash');
+is(exists($a{$utf8}), 1, 'Found UTF-8 key in shared hash');
+is(exists($a{\&is}), 1, 'Found code ref key in shared hash');
+
+while (my ($key, $value) = each (%a)) {
+    if ($key eq $plain) {
+        is($key, $plain, 'Plain key in shared hash');
+    } elsif ($key eq $utf8) {
+        is($key, $utf8, 'UTF-8 key in shared hash');
+    } else {
+        is($key, \&is, 'Code ref key in shared hash');
+    }
+}
+
+my $a = &share({});
+$$a{$plain} = $plain;
+$$a{$utf8} = $utf8;
+$$a{\&is} = 'code';
+
+is(exists($$a{$plain}), 1, 'Found plain key in shared hash ref');
+is(exists($$a{$utf8}), 1, 'Found UTF-8 key in shared hash ref');
+is(exists($$a{\&is}), 1, 'Found code ref key in shared hash ref');
+
+while (my ($key, $value) = each (%$a)) {
+    if ($key eq $plain) {
+        is($key, $plain, 'Plain key in shared hash ref');
+    } elsif ($key eq $utf8) {
+        is($key, $utf8, 'UTF-8 key in shared hash ref');
+    } else {
+        is($key, \&is, 'Code ref key in shared hash ref');
+    }
+}
+
+exit(0);
+
+# EOF
diff --git a/ext/threads/shared/t/wait.t b/ext/threads/shared/t/wait.t
index c08e2ed788..de8d9f1428 100644
--- a/ext/threads/shared/t/wait.t
+++ b/ext/threads/shared/t/wait.t
@@ -1,42 +1,31 @@
 use strict;
 use warnings;
 
-use Config;
 BEGIN {
+    # Import test.pl into its own package
+
     if ($ENV{'PERL_CORE'}){
         chdir 't';
         unshift @INC, '../lib';
+        {
+            package Test;
+            require 'test.pl';
+        }
+    } else {
+        {
+            package Test;
+            require 't/test.pl';
+        }
     }
+
+    use Config;
     if (! $Config{'useithreads'}) {
-        print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
-        exit(0);
+        Test::skip_all(q/Perl not compiled with 'useithreads'/);
     }
 }
 
 use ExtUtils::testlib;
 
-### Self-destruct timer child process
-my $TIMEOUT = 600;
-my $timer_pid;
-
-if ($Config{'d_fork'}) {
-    $timer_pid = fork();
-    if (defined($timer_pid) && ($timer_pid == 0)) {
-        # Child process
-        my $ppid = getppid();
-
-        # Sleep for timeout period
-        sleep($TIMEOUT - 2);   # Workaround for perlbug #49073
-        sleep(2);              # Wait for parent to exit
-
-        # Kill parent if it still exists
-        kill('KILL', $ppid) if (kill(0, $ppid));
-        exit(0);
-    }
-    # Parent will kill this process if tests finish on time
-}
-
-
 sub ok {
     my ($id, $ok, $name) = @_;
 
@@ -62,6 +51,7 @@ use threads::shared;
 my $TEST = 1;
 ok($TEST++, 1, 'Loaded');
 
+Test::watchdog(600);   # In case we get stuck
 
 ### Start of Testing ###
 
@@ -355,11 +345,6 @@ SYNCH_REFS: {
 
 } # -- SYNCH_REFS block
 
-# Kill timer process
-if ($timer_pid && kill(0, $timer_pid)) {
-    kill('KILL', $timer_pid);
-}
-
 # Done
 exit(0);
 
diff --git a/ext/threads/shared/t/waithires.t b/ext/threads/shared/t/waithires.t
index 2817334144..82913cae91 100644
--- a/ext/threads/shared/t/waithires.t
+++ b/ext/threads/shared/t/waithires.t
@@ -1,50 +1,37 @@
 use strict;
 use warnings;
 
-use Config;
 BEGIN {
+    # Import test.pl into its own package
+
     if ($ENV{'PERL_CORE'}){
         chdir 't';
         unshift @INC, '../lib';
+        {
+            package Test;
+            require 'test.pl';
+        }
+    } else {
+        {
+            package Test;
+            require 't/test.pl';
+        }
     }
+
+    use Config;
     if (! $Config{'useithreads'}) {
-        print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
-        exit(0);
+        Test::skip_all(q/Perl not compiled with 'useithreads'/);
     }
+
     eval {
         require Time::HiRes;
         Time::HiRes->import('time');
     };
-    if ($@) {
-        print("1..0 # SKIP Time::HiRes not available.\n");
-        exit(0);
-    }
+    Test::skip_all('Time::HiRes not available') if ($@);
 }
 
 use ExtUtils::testlib;
 
-### Self-destruct timer child process
-my $TIMEOUT = 60;
-my $timer_pid;
-
-if ($Config{'d_fork'}) {
-    $timer_pid = fork();
-    if (defined($timer_pid) && ($timer_pid == 0)) {
-        # Child process
-        my $ppid = getppid();
-
-        # Sleep for timeout period
-        sleep($TIMEOUT - 2);   # Workaround for perlbug #49073
-        sleep(2);              # Wait for parent to exit
-
-        # Kill parent if it still exists
-        kill('KILL', $ppid) if (kill(0, $ppid));
-        exit(0);
-    }
-    # Parent will kill this process if tests finish on time
-}
-
-
 sub ok {
     my ($id, $ok, $name) = @_;
 
@@ -70,6 +57,7 @@ use threads::shared;
 my $TEST = 1;
 ok($TEST++, 1, 'Loaded');
 
+Test::watchdog(60);   # In case we get stuck
 
 ### Start of Testing ###
 
@@ -297,11 +285,6 @@ SYNCH_REFS: {
 
 } # -- SYNCH_REFS block
 
-# Kill timer process
-if ($timer_pid && kill(0, $timer_pid)) {
-    kill('KILL', $timer_pid);
-}
-
 # Done
 exit(0);