From: Nicholas Clark <nick@ccl4.org>
Date: Sat, 4 May 2002 00:30:43 +0000 (+0100)
Subject: Re: Data::Dumper tests with -Mutf8
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d075f8ed0c85617a33177fa8812167b4177c2522;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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
--- 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;
+  }
+}