Re: Data::Dumper tests with -Mutf8

Message-ID: <20020503233042.GF294@Bagpuss.unfortu.net>

p4raw-id: //depot/perl@16389

diff --git a/ext/Data/Dumper/Dumper.xs b/ext/Data/Dumper/Dumper.xs
index 383707a..0e12cbf 100644 (file)
--- a/ext/Data/Dumper/Dumper.xs
+++ b/ext/Data/Dumper/Dumper.xs
@@ -592,7 +592,8 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
                    svp = av_fetch(keys, i, FALSE);
                    keysv = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
                    key = SvPV(keysv, keylen);
-                   svp = hv_fetch((HV*)ival, key, keylen, 0);
+                   svp = hv_fetch((HV*)ival, key,
+                                   SvUTF8(keysv) ? -keylen : keylen, 0);
                    hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
                }
                else {
@@ -605,15 +606,16 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
                klen = keylen;
 
                if (do_utf8) {
-                   char *okey = SvPVX(retval) + SvCUR(retval);
+                   STRLEN ocur;
                    I32 nlen;
 
                    sv_catsv(retval, totpad);
                    sv_catsv(retval, ipad);
+                    ocur = SvCUR(retval);
                    nlen = esc_q_utf8(aTHX_ retval, key, klen);
 
                    sname = newSVsv(iname);
-                   sv_catpvn(sname, okey, nlen);
+                   sv_catpvn(sname, SvPVX(retval) + ocur, nlen);
                    sv_catpvn(sname, "}", 1);
                }
                else {

diff --git a/ext/Data/Dumper/t/dumper.t b/ext/Data/Dumper/t/dumper.t
index d33af74..2955a7f 100755 (executable)
--- a/ext/Data/Dumper/t/dumper.t
+++ b/ext/Data/Dumper/t/dumper.t
@@ -67,11 +67,11 @@ sub TEST {
 $Data::Dumper::Useperl = 1;
 if (defined &Data::Dumper::Dumpxs) {
   print "### XS extension loaded, will run XS tests\n";
-  $TMAX = 339; $XS = 1;
+  $TMAX = 351; $XS = 1;
 }
 else {
   print "### XS extensions not loaded, will NOT run XS tests\n";
-  $TMAX = 171; $XS = 0;
+  $TMAX = 177; $XS = 0;
 }
 
 print "1..$TMAX\n";
@@ -1310,3 +1310,27 @@ EOT
     TEST q(Data::Dumper->Dumpxs([$a])), "XS utf8 flag with '";
   }
 }
+
+# Jarkko found that -Mutf8 caused some tests to fail.  Turns out that there
+# was an otherwise untested code path in the XS for utf8 hash keys with purity
+# 1
+
+{
+  $WANT = <<'EOT';
+#$ping = \*::ping;
+#*::ping = \5;
+#*::ping = {
+#  "\x{decaf}\x{decaf}\x{decaf}\x{decaf}" => do{my $o}
+#};
+#*::ping{HASH}->{"\x{decaf}\x{decaf}\x{decaf}\x{decaf}"} = *::ping{SCALAR};
+#%pong = %{*::ping{HASH}};
+EOT
+  local $Data::Dumper::Purity = 1;
+  local $Data::Dumper::Sortkeys;
+  $ping = 5;
+  %ping = (chr (0xDECAF) x 4  =>\$ping);
+  for $Data::Dumper::Sortkeys (0, 1) {
+    TEST q(Data::Dumper->Dump([\\*ping, \\%ping], ['*ping', '*pong']));
+    TEST q(Data::Dumper->Dumpxs([\\*ping, \\%ping], ['*ping', '*pong'])) if $XS;
+  }
+}