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 (file)
--- a/ext/Data/Dumper/Changes
+++ b/ext/Data/Dumper/Changes
@@ -6,6 +6,10 @@ HISTORY - public release history for Data::Dumper
 
 =over 8
 
 
 =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'>.
 =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 (file)
--- a/ext/Data/Dumper/Dumper.pm
+++ b/ext/Data/Dumper/Dumper.pm
@@ -645,6 +645,10 @@ sub qquote {
   return qq("$_");
 }
 
   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__
 
 1;
 __END__
 


@@ -1193,6 +1197,9 @@ XSUB implementation does not support them.
 
 SCALAR objects have the weirdest looking C<bless> workaround.
 
 
 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
 =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
 
 
 =head1 VERSION
 

-Version 2.12   (unreleased)
+Version 2.121  (Aug 24 2003)

 
 =head1 SEE ALSO
 
 
 =head1 SEE ALSO
 

diff --git a/ext/Data/Dumper/Dumper.xs b/ext/Data/Dumper/Dumper.xs
index 743781b..44dee9e 100644 (file)
--- a/ext/Data/Dumper/Dumper.xs
+++ b/ext/Data/Dumper/Dumper.xs
@@ -3,26 +3,6 @@
 #include "perl.h"
 #include "XSUB.h"
 
 #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);
 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);
 
                    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)
 /* 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),
                (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);
            }
        }
                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 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))) {
                    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);
                    }
                        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);
                    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);
                    sortsv(AvARRAY(keys), 
                           av_len(keys)+1, 
                           Perl_sv_cmp);

+# endif

 #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);
                    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);
                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);
            }
        }
 
                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);
             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.
             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);
                        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)
                        
                        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 (executable)
--- a/ext/Data/Dumper/t/dumper.t
+++ b/ext/Data/Dumper/t/dumper.t
@@ -4,12 +4,14 @@
 #
 
 BEGIN {
 #
 
 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");
 }
 
        : "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)
 # 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
 
 #$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;
   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) {
   $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 (executable)
--- a/ext/Data/Dumper/t/overload.t
+++ b/ext/Data/Dumper/t/overload.t
@@ -1,12 +1,15 @@
 #!./perl -w
 
 BEGIN {
 #!./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 (executable)
--- a/ext/Data/Dumper/t/pair.t
+++ b/ext/Data/Dumper/t/pair.t
@@ -4,12 +4,15 @@
 #
 
 BEGIN {
 #
 
 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;
+        }

     }
 }
 
     }
 }