Accessing unicode keys in tie hashes via hv_exists was broken.

(pp_exists uses hv_exists_ent, which isn't broken)
I expect an equivalent bug in hv_delete

p4raw-id: //depot/perl@21734

diff --git a/MANIFEST b/MANIFEST
index 787e1d2..4290128 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -771,6 +771,7 @@ ext/XS/APItest/APItest.xs   XS::APItest extension
 ext/XS/APItest/Makefile.PL     XS::APItest extension
 ext/XS/APItest/MANIFEST                XS::APItest extension
 ext/XS/APItest/README          XS::APItest extension
+ext/XS/APItest/t/hash.t                XS::APItest extension
 ext/XS/APItest/t/printf.t      XS::APItest extension
 ext/XS/Typemap/Makefile.PL     XS::Typemap extension
 ext/XS/Typemap/README          XS::Typemap extension

diff --git a/ext/XS/APItest/APItest.pm b/ext/XS/APItest/APItest.pm
index 581fa38..322fdc6 100644 (file)
--- a/ext/XS/APItest/APItest.pm
+++ b/ext/XS/APItest/APItest.pm
@@ -16,7 +16,7 @@ our @EXPORT = qw( print_double print_int print_long
                  print_float print_long_double have_long_double print_flush
 );
 
-our $VERSION = '0.02';
+our $VERSION = '0.03';
 
 bootstrap XS::APItest $VERSION;
 

diff --git a/ext/XS/APItest/APItest.xs b/ext/XS/APItest/APItest.xs
index b141252..1fac6cb 100644 (file)
--- a/ext/XS/APItest/APItest.xs
+++ b/ext/XS/APItest/APItest.xs
@@ -2,6 +2,36 @@
 #include "perl.h"
 #include "XSUB.h"
 
+
+MODULE = XS::APItest:Hash              PACKAGE = XS::APItest::Hash
+
+bool
+exists(hash, key_sv)
+       PREINIT:
+       STRLEN len;
+       const char *key;
+       INPUT:
+       HV *hash
+       SV *key_sv
+       CODE:
+       key = SvPV(key_sv, len);
+       RETVAL = hv_exists(hash, key, SvUTF8(key_sv) ? -len : len);
+        OUTPUT:
+        RETVAL
+
+=pod
+
+sub TIEHASH  { bless {}, $_[0] }
+sub STORE    { $_[0]->{$_[1]} = $_[2] }
+sub FETCH    { $_[0]->{$_[1]} }
+sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
+sub NEXTKEY  { each %{$_[0]} }
+sub EXISTS   { exists $_[0]->{$_[1]} }
+sub DELETE   { delete $_[0]->{$_[1]} }
+sub CLEAR    { %{$_[0]} = () }
+
+=cut
+
 MODULE = XS::APItest           PACKAGE = XS::APItest
 
 PROTOTYPES: DISABLE

diff --git a/ext/XS/APItest/MANIFEST b/ext/XS/APItest/MANIFEST
index 7a7e094..5718148 100644 (file)
--- a/ext/XS/APItest/MANIFEST
+++ b/ext/XS/APItest/MANIFEST
@@ -3,4 +3,5 @@ MANIFEST
 README
 APItest.pm
 APItest.xs
+t/hash.t
 t/printf.t

diff --git a/ext/XS/APItest/t/hash.t b/ext/XS/APItest/t/hash.t
new file mode 100644 (file)
index 0000000..0fc5eae
--- /dev/null
+++ b/ext/XS/APItest/t/hash.t
@@ -0,0 +1,71 @@
+#!perl -w
+
+BEGIN {
+  chdir 't' if -d 't';
+  @INC = '../lib';
+  push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
+  require Config; import Config;
+  if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
+    # Look, I'm using this fully-qualified variable more than once!
+    my $arch = $MacPerl::Architecture;
+    print "1..0 # Skip: XS::APItest was not built\n";
+    exit 0;
+  }
+}
+
+use Tie::Hash;
+
+my @testkeys = ('N', chr 256);
+
+my $temp = chr 258;
+utf8::encode $temp;
+
+my @keys = (@testkeys, $temp);
+my (%hash, %tiehash);
+tie %tiehash, 'Tie::StdHash';
+
+@hash{@keys} = ();
+@tiehash{@keys} = ();
+
+
+use Test::More 'no_plan';
+
+use_ok('XS::APItest');
+
+sub test_present {
+  my $key = shift;
+  my $printable = join ',', map {ord} split //, $key;
+
+  ok (exists $hash{$key}, "hv_exists_ent present $printable");
+  ok (XS::APItest::Hash::exists (\%hash, $key), "hv_exists present $printable");
+
+  ok (exists $tiehash{$key}, "hv_exists_ent tie present  $printable");
+  ok (XS::APItest::Hash::exists (\%tiehash, $key),
+      "hv_exists tie present $printable");
+}
+
+sub test_absent {
+  my $key = shift;
+  my $printable = join ',', map {ord} split //, $key;
+
+  ok (!exists $hash{$key}, "hv_exists_ent absent $printable");
+  ok (!XS::APItest::Hash::exists (\%hash, $key), "hv_exists absent $printable");
+
+  ok (!exists $tiehash{$key}, "hv_exists_ent tie absent  $printable");
+  ok (!XS::APItest::Hash::exists (\%tiehash, $key),
+      "hv_exists tie absent $printable");
+}
+
+foreach my $key (@testkeys) {
+  test_present ($key);
+
+  my $lckey = lc $key;
+  test_absent ($lckey);
+
+  my $unikey = $key;
+  utf8::encode $unikey;
+
+  test_absent ($unikey) unless $unikey eq $key;
+}
+
+test_absent (chr 258);

diff --git a/hv.c b/hv.c
index 457fd5a..2d9b06e 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -1276,6 +1276,15 @@ Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
     if (SvRMAGICAL(hv)) {
        if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
            sv = sv_newmortal();
+           if (is_utf8) {
+               /* This hack based on the code in hv_exists_ent seems to be
+                  the easiest way to pass the utf8 flag through and fix
+                  the bug in hv_exists for tied hashes with utf8 keys.  */
+               SV *keysv = sv_2mortal(newSVpvn(key, klen));
+               SvUTF8_on(keysv);
+               key = (char *)keysv;
+               klen = HEf_SVKEY;
+           }
            mg_copy((SV*)hv, sv, key, klen);
            magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem));
            return (bool)SvTRUE(sv);