From: Ilya Martynov <ilya@martynov.org>
Date: Fri, 5 Sep 2003 00:33:46 +0000 (+0400)
Subject: Re: [PATCH] Data::Dumper 2.121
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=fec5e1eb396a5ed15ea5ee0c269e61721c3e028b;p=p5sagit%2Fp5-mst-13.2.git

Re: [PATCH] Data::Dumper 2.121
Message-ID: <87ad9kuwd1.fsf@abra.ru>

p4raw-id: //depot/perl@21036
---

diff --git a/ext/Data/Dumper/Changes b/ext/Data/Dumper/Changes
index ea1b53b..8cee096 100644
--- a/ext/Data/Dumper/Changes
+++ b/ext/Data/Dumper/Changes
@@ -6,6 +6,10 @@ HISTORY - public release history for Data::Dumper
 
 =over 8
 
+=item 2.121 (Aug 24 2003)
+
+Backport to 5.6.1 by Ilya Martynov <ilya@martynov.org>.
+
 =item 2.11  (unreleased)
 
 C<0> is now dumped as such, not as C<'0'>.
diff --git a/ext/Data/Dumper/Dumper.pm b/ext/Data/Dumper/Dumper.pm
index 9d11c64..1760381 100644
--- a/ext/Data/Dumper/Dumper.pm
+++ b/ext/Data/Dumper/Dumper.pm
@@ -645,6 +645,10 @@ sub qquote {
   return qq("$_");
 }
 
+# helper sub to sort hash keys in Perl < 5.8.0 where we don't have
+# access to sortsv() from XS
+sub _sortkeys { [ sort keys %{$_[0]} ] }
+
 1;
 __END__
 
@@ -1193,6 +1197,9 @@ XSUB implementation does not support them.
 
 SCALAR objects have the weirdest looking C<bless> workaround.
 
+Pure Perl version of C<Data::Dumper> escapes UTF-8 strings correctly
+only in Perl 5.8.0 and later.
+
 =head2 NOTE
 
 Starting from Perl 5.8.1 different runs of Perl will have different
@@ -1215,7 +1222,7 @@ modify it under the same terms as Perl itself.
 
 =head1 VERSION
 
-Version 2.12   (unreleased)
+Version 2.121  (Aug 24 2003)
 
 =head1 SEE ALSO
 
diff --git a/ext/Data/Dumper/Dumper.xs b/ext/Data/Dumper/Dumper.xs
index 743781b..44dee9e 100644
--- a/ext/Data/Dumper/Dumper.xs
+++ b/ext/Data/Dumper/Dumper.xs
@@ -3,26 +3,6 @@
 #include "perl.h"
 #include "XSUB.h"
 
-#ifndef PERL_VERSION
-#    include <patchlevel.h>
-#    if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL)))
-#        include <could_not_find_Perl_patchlevel.h>
-#    endif
-#    define PERL_VERSION PATCHLEVEL
-#endif
-
-#if PERL_VERSION < 5
-#  ifndef PL_sv_undef
-#    define PL_sv_undef	sv_undef
-#  endif
-#  ifndef ERRSV
-#    define ERRSV	GvSV(errgv)
-#  endif
-#  ifndef newSVpvn
-#    define newSVpvn	newSVpv
-#  endif
-#endif
-
 static I32 num_q (char *s, STRLEN slen);
 static I32 esc_q (char *dest, char *src, STRLEN slen);
 static I32 esc_q_utf8 (pTHX_ SV *sv, char *src, STRLEN slen);
@@ -34,6 +14,39 @@ static I32 DD_dump (pTHX_ SV *val, char *name, STRLEN namelen, SV *retval,
 		    I32 purity, I32 deepcopy, I32 quotekeys, SV *bless,
 		    I32 maxdepth, SV *sortkeys);
 
+#if PERL_VERSION <= 6 /* Perl 5.6 and earlier */
+
+# ifdef EBCDIC
+#  define UNI_TO_NATIVE(ch) (((ch) > 255) ? (ch) : ASCII_TO_NATIVE(ch))
+# else
+#  define UNI_TO_NATIVE(ch) (ch)
+# endif
+
+UV
+Perl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen)
+{
+    UV uv = utf8_to_uv(s, UTF8_MAXLEN, retlen,
+                    ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
+    return UNI_TO_NATIVE(uv);
+}
+
+# if !defined(PERL_IMPLICIT_CONTEXT)
+#  define utf8_to_uvchr	     Perl_utf8_to_uvchr
+# else
+#  define utf8_to_uvchr(a,b) Perl_utf8_to_uvchr(aTHX_ a,b)
+# endif
+
+#endif /* PERL_VERSION <= 6 */
+
+/* Changes in 5.7 series mean that now IOK is only set if scalar is
+   precisely integer but in 5.6 and earlier we need to do a more
+   complex test  */
+#if PERL_VERSION <= 6
+#define DD_is_integer(sv) (SvIOK(sv) && (SvIsUV(val) ? SvUV(sv) == SvNV(sv) : SvIV(sv) == SvNV(sv)))
+#else
+#define DD_is_integer(sv) SvIOK(sv)
+#endif
+
 /* does a string need to be protected? */
 static I32
 needs_quote(register char *s)
@@ -339,7 +352,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 		(void)SvREFCNT_inc(val);
 		av_push(seenentry, val);
 		(void)hv_store(seenhv, id, strlen(id),
-			       newRV((SV*)seenentry), 0);
+			       newRV_inc((SV*)seenentry), 0);
 		SvREFCNT_dec(seenentry);
 	    }
 	}
@@ -546,6 +559,9 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 	    /* If requested, get a sorted/filtered array of hash keys */
 	    if (sortkeys) {
 		if (sortkeys == &PL_sv_yes) {
+#if PERL_VERSION < 8
+                    sortkeys = sv_2mortal(newSVpvn("Data::Dumper::_sortkeys", 23));
+#else
 		    keys = newAV();
 		    (void)hv_iterinit((HV*)ival);
 		    while ((entry = hv_iternext((HV*)ival))) {
@@ -553,17 +569,18 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 			SvREFCNT_inc(sv);
 			av_push(keys, sv);
 		    }
-#ifdef USE_LOCALE_NUMERIC
+# ifdef USE_LOCALE_NUMERIC
 		    sortsv(AvARRAY(keys), 
 			   av_len(keys)+1, 
 			   IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp);
-#else
+# else
 		    sortsv(AvARRAY(keys), 
 			   av_len(keys)+1, 
 			   Perl_sv_cmp);
+# endif
 #endif
 		}
-		else {
+		if (sortkeys != &PL_sv_yes) {
 		    dSP; ENTER; SAVETMPS; PUSHMARK(sp);
 		    XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
 		    i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
@@ -759,24 +776,19 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 		sv_catpvn(namesv, name, namelen);
 		seenentry = newAV();
 		av_push(seenentry, namesv);
-		av_push(seenentry, newRV(val));
-		(void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0);
+		av_push(seenentry, newRV_inc(val));
+		(void)hv_store(seenhv, id, strlen(id), newRV_inc((SV*)seenentry), 0);
 		SvREFCNT_dec(seenentry);
 	    }
 	}
 
-	if (SvIOK(val)) {
+        if (DD_is_integer(val)) {
             STRLEN len;
 	    if (SvIsUV(val))
 	      (void) sprintf(tmpbuf, "%"UVuf, SvUV(val));
 	    else
 	      (void) sprintf(tmpbuf, "%"IVdf, SvIV(val));
             len = strlen(tmpbuf);
-            /* For 5.6.x and earlier will need to change this test to check
-               NV if NOK, as there NOK trumps IOK, and NV=3.5,IV=3 is valid.
-               Current code will Dump that as $VAR1 = 3;
-               Changes in 5.7 series mean that now IOK is only set if scalar
-               is precisely integer.  */
             if (SvPOK(val)) {
               /* Need to check to see if this is a string such as " 0".
                  I'm assuming from sprintf isn't going to clash with utf8.
@@ -841,7 +853,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 			sv_catpvn(nname, entries[j], sizes[j]);
 			sv_catpvn(postentry, " = ", 3);
 			av_push(postav, postentry);
-			e = newRV(e);
+			e = newRV_inc(e);
 			
 			SvCUR(newapad) = 0;
 			if (indent >= 2)
diff --git a/ext/Data/Dumper/t/dumper.t b/ext/Data/Dumper/t/dumper.t
index 7663439..92cd3ef 100755
--- a/ext/Data/Dumper/t/dumper.t
+++ b/ext/Data/Dumper/t/dumper.t
@@ -4,12 +4,14 @@
 #
 
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
-    require Config; import Config;
-    if ($Config{'extensions'} !~ /\bData\/Dumper\b/) {
-      print "1..0 # Skip: Data::Dumper was not built\n";
-      exit 0;
+    if ($ENV{PERL_CORE}){
+        chdir 't' if -d 't';
+        @INC = '../lib';
+        require Config; import Config;
+        if ($Config{'extensions'} !~ /\bData\/Dumper\b/) {
+            print "1..0 # Skip: Data::Dumper was not built\n";
+            exit 0;
+        }
     }
 }
 
@@ -64,6 +66,13 @@ sub TEST {
 	: "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n");
 }
 
+sub SKIP_TEST {
+  my $reason = shift;
+  ++$TNUM; print "ok $TNUM # skip $reason\n";
+  ++$TNUM; print "ok $TNUM # skip $reason\n";
+  ++$TNUM; print "ok $TNUM # skip $reason\n";
+}
+
 # Force Data::Dumper::Dump to use perl. We test Dumpxs explicitly by calling
 # it direct. Out here it lets us knobble the next if to test that the perl
 # only tests do work (and count correctly)
@@ -827,10 +836,13 @@ TEST q(Data::Dumper->new([$b],['b'])->Purity(1)->Dumpxs;)
 #$a = "\x{9c10}";
 EOT
 
-  TEST q(Data::Dumper->Dump([$a], ['a'])), "\\x{9c10}";
+  if($] >= 5.007) {
+    TEST q(Data::Dumper->Dump([$a], ['a'])), "\\x{9c10}";
+  } else {
+    SKIP_TEST "Incomplete support for UTF-8 in old perls";
+  }
   TEST q(Data::Dumper->Dumpxs([$a], ['a'])), "XS \\x{9c10}"
 	if $XS;
-
 }
 
 {
@@ -1332,8 +1344,13 @@ EOT
   $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;
+    if($] >= 5.007) {
+      TEST q(Data::Dumper->Dump([\\*ping, \\%ping], ['*ping', '*pong']));
+      TEST q(Data::Dumper->Dumpxs([\\*ping, \\%ping], ['*ping', '*pong'])) if $XS;
+    } else {
+      SKIP_TEST "Incomplete support for UTF-8 in old perls";
+      SKIP_TEST "Incomplete support for UTF-8 in old perls";
+    }
   }
 }
 
diff --git a/ext/Data/Dumper/t/overload.t b/ext/Data/Dumper/t/overload.t
index d4b3a92..09045f9 100755
--- a/ext/Data/Dumper/t/overload.t
+++ b/ext/Data/Dumper/t/overload.t
@@ -1,12 +1,15 @@
 #!./perl -w
 
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
-    require Config; import Config;
-    if ($Config{'extensions'} !~ /\bData\/Dumper\b/) {
-      print "1..0 # Skip: Data::Dumper was not built\n";
-      exit 0;
+    if ($ENV{PERL_CORE}){
+        chdir 't' if -d 't';
+        @INC = '../lib';
+        require Config; import Config;
+        no warnings 'once';
+        if ($Config{'extensions'} !~ /\bData\/Dumper\b/) {
+            print "1..0 # Skip: Data::Dumper was not built\n";
+            exit 0;
+        }
     }
 }
 
diff --git a/ext/Data/Dumper/t/pair.t b/ext/Data/Dumper/t/pair.t
index 569175d..c46ba6c 100755
--- a/ext/Data/Dumper/t/pair.t
+++ b/ext/Data/Dumper/t/pair.t
@@ -4,12 +4,15 @@
 #
 
 BEGIN {
-    chdir 't' if -d 't';
-    unshift @INC, '../lib';
-    require Config; import Config;
-    if ($Config{'extensions'} !~ /\bData\/Dumper\b/) {
-      print "1..0 # Skip: Data::Dumper was not built\n";
-      exit 0;
+    if ($ENV{PERL_CORE}){
+        chdir 't' if -d 't';
+        unshift @INC, '../lib';
+        require Config; import Config;
+        no warnings 'once';
+        if ($Config{'extensions'} !~ /\bData\/Dumper\b/) {
+            print "1..0 # Skip: Data::Dumper was not built\n";
+            exit 0;
+        }
     }
 }