threads::shared 1.24 (phase 2)

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

Additional changes to threads::shared for UTF-8 hash keys.

p4raw-id: //depot/perl@34102

4 files changed, 47 insertions, 36 deletions

diff --git a/ext/threads/shared/shared.xs b/ext/threads/shared/shared.xs
index b7447964a2..0848da91d8 100644
--- a/ext/threads/shared/shared.xs
+++ b/ext/threads/shared/shared.xs
@@ -876,7 +876,10 @@ 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 = SvPVutf8((SV *)mg->mg_ptr, len);
+            key = SvPV((SV *)mg->mg_ptr, len);
+            if (SvUTF8((SV *)mg->mg_ptr)) {
+                len = -len;
+            }
         }
         SHARED_CONTEXT;
         svp = hv_fetch((HV*) saggregate, key, len, 0);
@@ -926,8 +929,12 @@ sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
         char *key = mg->mg_ptr;
         STRLEN len = mg->mg_len;
         assert ( mg->mg_ptr != 0 );
-        if (mg->mg_len == HEf_SVKEY)
-           key = SvPVutf8((SV *)mg->mg_ptr, len);
+        if (mg->mg_len == HEf_SVKEY) {
+            key = SvPV((SV *)mg->mg_ptr, len);
+            if (SvUTF8((SV *)mg->mg_ptr)) {
+                len = -len;
+            }
+        }
         SHARED_CONTEXT;
         svp = hv_fetch((HV*) saggregate, key, len, 1);
     }
@@ -957,8 +964,12 @@ sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
         char *key = mg->mg_ptr;
         STRLEN len = mg->mg_len;
         assert ( mg->mg_ptr != 0 );
-        if (mg->mg_len == HEf_SVKEY)
-           key = SvPVutf8((SV *)mg->mg_ptr, len);
+        if (mg->mg_len == HEf_SVKEY) {
+            key = SvPV((SV *)mg->mg_ptr, len);
+            if (SvUTF8((SV *)mg->mg_ptr)) {
+                len = -len;
+            }
+        }
         SHARED_CONTEXT;
         hv_delete((HV*) saggregate, key, len, G_DISCARD);
     }
@@ -1277,6 +1288,9 @@ EXISTS(SV *obj, SV *index)
         } else {
             STRLEN len;
             char *key = SvPVutf8(index, len);
+            if (SvUTF8(index)) {
+                len = -len;
+            }
             SHARED_EDIT;
             exists = hv_exists((HV*) sobj, key, len);
         }
@@ -1298,9 +1312,10 @@ FIRSTKEY(SV *obj)
         hv_iterinit((HV*) sobj);
         entry = hv_iternext((HV*) sobj);
         if (entry) {
+            I32 utf8 = HeKUTF8(entry);
             key = hv_iterkey(entry,&len);
             CALLER_CONTEXT;
-            ST(0) = sv_2mortal(newSVpvn_utf8(key, len, 1));
+            ST(0) = sv_2mortal(newSVpvn_utf8(key, len, utf8));
         } else {
             CALLER_CONTEXT;
             ST(0) = &PL_sv_undef;
@@ -1324,9 +1339,10 @@ NEXTKEY(SV *obj, SV *oldkey)
         SHARED_CONTEXT;
         entry = hv_iternext((HV*) sobj);
         if (entry) {
+            I32 utf8 = HeKUTF8(entry);
             key = hv_iterkey(entry,&len);
             CALLER_CONTEXT;
-            ST(0) = sv_2mortal(newSVpvn_utf8(key, len, 1));
+            ST(0) = sv_2mortal(newSVpvn_utf8(key, len, utf8));
         } else {
             CALLER_CONTEXT;
             ST(0) = &PL_sv_undef;
diff --git a/ext/threads/shared/t/utf8.t b/ext/threads/shared/t/utf8.t
index f2e0ac3c77..42e7c3f414 100644
--- a/ext/threads/shared/t/utf8.t
+++ b/ext/threads/shared/t/utf8.t
@@ -51,42 +51,47 @@ binmode STDOUT, ":utf8";
 
 my $plain = 'foo';
 my $utf8 = "\x{123}\x{84}\x{20F}\x{2C1}";
+my $code = \&is;
 
 my %a :shared;
 $a{$plain} = $plain;
 $a{$utf8} = $utf8;
-$a{\&is} = 'code';
+$a{$code} = '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');
+is(exists($a{$code}), 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');
+    } elsif ($key eq "$code") {
+        is($key, "$code", 'Code ref key in shared hash');
     } else {
-        is($key, \&is, 'Code ref key in shared hash');
+        is($key, "???", 'Bad key');
     }
 }
 
 my $a = &share({});
 $$a{$plain} = $plain;
 $$a{$utf8} = $utf8;
-$$a{\&is} = 'code';
+$$a{$code} = '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');
+is(exists($$a{$code}), 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');
+    } elsif ($key eq "$code") {
+        is($key, "$code", 'Code ref key in shared hash ref');
     } else {
-        is($key, \&is, 'Code ref key in shared hash ref');
+        is($key, "???", 'Bad key');
     }
 }
 
diff --git a/ext/threads/shared/t/wait.t b/ext/threads/shared/t/wait.t
index de8d9f1428..e8a7a3646c 100644
--- a/ext/threads/shared/t/wait.t
+++ b/ext/threads/shared/t/wait.t
@@ -2,26 +2,21 @@ use strict;
 use warnings;
 
 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'}) {
         Test::skip_all(q/Perl not compiled with 'useithreads'/);
     }
+
+    # Import test.pl into its own package
+    {
+        package Test;
+        require($ENV{PERL_CORE} ? 'test.pl' : 't/test.pl');
+    }
 }
 
 use ExtUtils::testlib;
@@ -51,7 +46,7 @@ use threads::shared;
 my $TEST = 1;
 ok($TEST++, 1, 'Loaded');
 
-Test::watchdog(600);   # In case we get stuck
+Test::watchdog(60);   # In case we get stuck
 
 ### Start of Testing ###
 
diff --git a/ext/threads/shared/t/waithires.t b/ext/threads/shared/t/waithires.t
index 82913cae91..8bb7b059ee 100644
--- a/ext/threads/shared/t/waithires.t
+++ b/ext/threads/shared/t/waithires.t
@@ -2,20 +2,9 @@ use strict;
 use warnings;
 
 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;
@@ -23,6 +12,12 @@ BEGIN {
         Test::skip_all(q/Perl not compiled with 'useithreads'/);
     }
 
+    # Import test.pl into its own package
+    {
+        package Test;
+        require($ENV{PERL_CORE} ? 'test.pl' : 't/test.pl');
+    }
+
     eval {
         require Time::HiRes;
         Time::HiRes->import('time');