Patch for Data::Dumper 2.12 to Allow Custom Hash Key/Value Separator

Message-ID: <3E576A58.8010901@chocolatey.com>

p4raw-id: //depot/perl@19005

diff --git a/MANIFEST b/MANIFEST
index 11ea10c..320eae5 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -129,6 +129,7 @@ ext/Data/Dumper/Dumper.pm   Data pretty printer, module
 ext/Data/Dumper/Dumper.xs      Data pretty printer, externals
 ext/Data/Dumper/Makefile.PL    Data pretty printer, makefile writer
 ext/Data/Dumper/t/dumper.t     See if Data::Dumper works
+ext/Data/Dumper/t/pair.t       See if Data::Dumper pair separator works
 ext/Data/Dumper/t/overload.t   See if Data::Dumper works for overloaded data
 ext/Data/Dumper/Todo           Data pretty printer, futures
 ext/DB_File/Changes    Berkeley DB extension change log

diff --git a/ext/Data/Dumper/Dumper.pm b/ext/Data/Dumper/Dumper.pm
index 8e5320e..9034544 100644 (file)
--- a/ext/Data/Dumper/Dumper.pm
+++ b/ext/Data/Dumper/Dumper.pm
@@ -40,6 +40,7 @@ $Quotekeys = 1 unless defined $Quotekeys;
 $Bless = "bless" unless defined $Bless;
 #$Expdepth = 0 unless defined $Expdepth;
 $Maxdepth = 0 unless defined $Maxdepth;
+$Pair = ' => ' unless defined $Pair;
 $Useperl = 0 unless defined $Useperl;
 $Sortkeys = 0 unless defined $Sortkeys;
 $Deparse = 0 unless defined $Deparse;
@@ -64,6 +65,7 @@ sub new {
             xpad       => "",          # padding-per-level
             apad       => "",          # added padding for hash keys n such
             sep        => "",          # list separator
+            pair       => $Pair,       # hash key/value separator: defaults to ' => '
             seen       => {},          # local (nested) refs (id => [name, val])
             todump     => $v,          # values to dump []
             names      => $n,          # optional names for values []
@@ -332,10 +334,11 @@ sub _dump {
       $out .= ($name =~ /^\@/) ? ')' : ']';
     }
     elsif ($realtype eq 'HASH') {
-      my($k, $v, $pad, $lpad, $mname);
+      my($k, $v, $pad, $lpad, $mname, $pair);
       $out .= ($name =~ /^\%/) ? '(' : '{';
       $pad = $s->{sep} . $s->{pad} . $s->{apad};
       $lpad = $s->{apad};
+      $pair = $s->{pair};
       ($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) :
        # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar}
        ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) :
@@ -361,7 +364,7 @@ sub _dump {
        my $nk = $s->_dump($k, "");
        $nk = $1 if !$s->{quotekeys} and $nk =~ /^[\"\']([A-Za-z_]\w*)[\"\']$/;
        $sname = $mname . '{' . $nk . '}';
-       $out .= $pad . $ipad . $nk . " => ";
+       $out .= $pad . $ipad . $nk . $pair;
 
        # temporarily alter apad
        $s->{apad} .= (" " x (length($nk) + 4)) if $s->{indent} >= 2;
@@ -517,6 +520,11 @@ sub Indent {
   }
 }
 
+sub Pair {
+    my($s, $v) = @_;
+    defined($v) ? (($s->{pair} = $v), return $s) : $s->{pair};
+}
+
 sub Pad {
   my($s, $v) = @_;
   defined($v) ? (($s->{pad} = $v), return $s) : $s->{pad};
@@ -914,6 +922,19 @@ Default is C<bless>.
 
 =item *
 
+$Data::Dumper::Pair  I<or>  $I<OBJ>->Pair(I<[NEWVAL]>)
+
+Can be set to a string that specifies the separator between hash keys
+and values. To dump nested hash, array and scalar values to JavaScript,
+use: C<$Data::Dumper::Pair = ' : ';>. Implementing C<bless> in JavaScript
+is left as an exercise for the reader.
+A function with the specified name exists, and accepts the same arguments
+as the builtin.
+
+Default is: C< =E<gt> >.
+
+=item *
+
 $Data::Dumper::Maxdepth  I<or>  $I<OBJ>->Maxdepth(I<[NEWVAL]>)
 
 Can be set to a positive integer that specifies the depth beyond which
@@ -1019,6 +1040,9 @@ distribution for more examples.)
     $Data::Dumper::Useqq = 1;          # print strings in double quotes
     print Dumper($boo);
 
+    $Data::Dumper::Pair = " : ";       # specify hash key/value separator
+    print Dumper($boo);
+
 
     ########
     # recursive structures

diff --git a/ext/Data/Dumper/Dumper.xs b/ext/Data/Dumper/Dumper.xs
index c0ab07c..743781b 100644 (file)
--- a/ext/Data/Dumper/Dumper.xs
+++ b/ext/Data/Dumper/Dumper.xs
@@ -29,7 +29,7 @@ static I32 esc_q_utf8 (pTHX_ SV *sv, char *src, STRLEN slen);
 static SV *sv_x (pTHX_ SV *sv, char *str, STRLEN len, I32 n);
 static I32 DD_dump (pTHX_ SV *val, char *name, STRLEN namelen, SV *retval,
                    HV *seenhv, AV *postav, I32 *levelp, I32 indent,
-                   SV *pad, SV *xpad, SV *apad, SV *sep,
+                   SV *pad, SV *xpad, SV *apad, SV *sep, SV *pair,
                    SV *freezer, SV *toaster,
                    I32 purity, I32 deepcopy, I32 quotekeys, SV *bless,
                    I32 maxdepth, SV *sortkeys);
@@ -224,7 +224,7 @@ sv_x(pTHX_ SV *sv, register char *str, STRLEN len, I32 n)
 static I32
 DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
        AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
-       SV *apad, SV *sep, SV *freezer, SV *toaster, I32 purity,
+       SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity,
        I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys)
 {
     char tmpbuf[128];
@@ -397,7 +397,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
            if (realpack) {                                  /* blessed */
                sv_catpvn(retval, "do{\\(my $o = ", 13);
                DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
-                       postav, levelp, indent, pad, xpad, apad, sep,
+                       postav, levelp, indent, pad, xpad, apad, sep, pair,
                        freezer, toaster, purity, deepcopy, quotekeys, bless,
                        maxdepth, sortkeys);
                sv_catpvn(retval, ")}", 2);
@@ -405,7 +405,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
            else {
                sv_catpvn(retval, "\\", 1);
                DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
-                       postav, levelp, indent, pad, xpad, apad, sep,
+                       postav, levelp, indent, pad, xpad, apad, sep, pair,
                        freezer, toaster, purity, deepcopy, quotekeys, bless,
                        maxdepth, sortkeys);
            }
@@ -417,7 +417,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
            sv_catpvn(namesv, "}", 1);
            sv_catpvn(retval, "\\", 1);
            DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
-                   postav, levelp,     indent, pad, xpad, apad, sep,
+                   postav, levelp,     indent, pad, xpad, apad, sep, pair,
                    freezer, toaster, purity, deepcopy, quotekeys, bless,
                    maxdepth, sortkeys);
            SvREFCNT_dec(namesv);
@@ -486,7 +486,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
                sv_catsv(retval, totpad);
                sv_catsv(retval, ipad);
                DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
-                       levelp, indent, pad, xpad, apad, sep,
+                       levelp, indent, pad, xpad, apad, sep, pair,
                        freezer, toaster, purity, deepcopy, quotekeys, bless,
                        maxdepth, sortkeys);
                if (ix < ixmax)
@@ -640,7 +640,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
                    There should also be less tests for the (probably currently)
                    more common doesn't need quoting case.
                    The code is also smaller (22044 vs 22260) because I've been
-                   able to pull the comon logic out to both sides.  */
+                   able to pull the common logic out to both sides.  */
                 if (quotekeys || needs_quote(key)) {
                     if (do_utf8) {
                         STRLEN ocur = SvCUR(retval);
@@ -671,7 +671,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
                 sv_catpvn(sname, nkey, nlen);
                 sv_catpvn(sname, "}", 1);
 
-               sv_catpvn(retval, " => ", 4);
+               sv_catsv(retval, pair);
                if (indent >= 2) {
                    char *extra;
                    I32 elen = 0;
@@ -687,7 +687,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
                    newapad = apad;
 
                DD_dump(aTHX_ hval, SvPVX(sname), SvCUR(sname), retval, seenhv,
-                       postav, levelp, indent, pad, xpad, newapad, sep,
+                       postav, levelp, indent, pad, xpad, newapad, sep, pair,
                        freezer, toaster, purity, deepcopy, quotekeys, bless,
                        maxdepth, sortkeys);
                SvREFCNT_dec(sname);
@@ -849,7 +849,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
                        
                        DD_dump(aTHX_ e, SvPVX(nname), SvCUR(nname), postentry,
                                seenhv, postav, &nlevel, indent, pad, xpad,
-                               newapad, sep, freezer, toaster, purity,
+                               newapad, sep, pair, freezer, toaster, purity,
                                deepcopy, quotekeys, bless, maxdepth, 
                                sortkeys);
                        SvREFCNT_dec(e);
@@ -914,7 +914,7 @@ Data_Dumper_Dumpxs(href, ...)
            I32 level = 0;
            I32 indent, terse, i, imax, postlen;
            SV **svp;
-           SV *val, *name, *pad, *xpad, *apad, *sep, *varname;
+           SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname;
            SV *freezer, *toaster, *bless, *sortkeys;
            I32 purity, deepcopy, quotekeys, maxdepth = 0;
            char tmpbuf[1024];
@@ -947,7 +947,7 @@ Data_Dumper_Dumpxs(href, ...)
 
            todumpav = namesav = Nullav;
            seenhv = Nullhv;
-           val = pad = xpad = apad = sep = varname
+           val = pad = xpad = apad = sep = pair = varname
                = freezer = toaster = bless = &PL_sv_undef;
            name = sv_newmortal();
            indent = 2;
@@ -983,6 +983,8 @@ Data_Dumper_Dumpxs(href, ...)
                    apad = *svp;
                if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
                    sep = *svp;
+               if ((svp = hv_fetch(hv, "pair", 4, FALSE)))
+                   pair = *svp;
                if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
                    varname = *svp;
                if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
@@ -1071,7 +1073,7 @@ Data_Dumper_Dumpxs(href, ...)
                        newapad = apad;
                
                    DD_dump(aTHX_ val, SvPVX(name), SvCUR(name), valstr, seenhv,
-                           postav, &level, indent, pad, xpad, newapad, sep,
+                           postav, &level, indent, pad, xpad, newapad, sep, pair,
                            freezer, toaster, purity, deepcopy, quotekeys,
                            bless, maxdepth, sortkeys);
                

diff --git a/ext/Data/Dumper/t/pair.t b/ext/Data/Dumper/t/pair.t
new file mode 100755 (executable)
index 0000000..569175d
--- /dev/null
+++ b/ext/Data/Dumper/t/pair.t
@@ -0,0 +1,61 @@
+#!./perl -w
+#
+# test for $Data::Dumper::Pair AKA Data::Dumper->new([ ... ])->Pair('...')
+#
+
+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;
+    }
+}
+
+use strict;
+use vars qw($want_colon $want_comma);
+use Test::More tests => 9;
+
+no warnings qw(once);
+
+require_ok 'Data::Dumper';
+
+my $HASH = { alpha => 'beta', gamma => 'vlissides' };
+my $WANT = q({'alpha' => 'beta','gamma' => 'vlissides'});
+
+$Data::Dumper::Useperl = 1;
+$Data::Dumper::Indent = 0;
+$Data::Dumper::Terse = 1;
+$Data::Dumper::Sortkeys = 1;
+
+$want_colon = $want_comma = $WANT;
+$want_colon =~ s/=>/:/g;
+$want_comma =~ s/ => /,/g;
+
+####################### XS Tests #####################
+
+SKIP: {
+    skip 'XS extension not loaded', 3 unless (defined &Data::Dumper::Dumpxs);
+    is (Data::Dumper::DumperX($HASH), $WANT, 
+       'XS: Default hash key/value separator: " => "');
+    local $Data::Dumper::Pair = ' : ';
+    is (Data::Dumper::DumperX($HASH), $want_colon, 'XS: $Data::Dumper::Pair = " : "');
+    my $dd = Data::Dumper->new([ $HASH ])->Pair(',');
+    is ($dd->Dumpxs(), $want_comma, 
+       'XS: Data::Dumper->new([ $HASH ])->Pair(",")->Dumpxs()');
+};
+
+###################### Perl Tests ####################
+
+{
+    is ($Data::Dumper::Pair, ' => ', 'Perl: $Data::Dumper::Pair eq " => "');
+    is (Data::Dumper::Dumper($HASH), $WANT, 
+       'Perl: Default hash key/value separator: " => "');
+    local $Data::Dumper::Pair = ' : ';
+    is (Data::Dumper::Dumper($HASH), $want_colon, 'Perl: $Data::Dumper::Pair = " : "');
+    my $dd = Data::Dumper->new([ $HASH ])->Pair(',');
+    is ($dd->Pair(), ',', 
+       'Perl: Data::Dumper->new([ $HASH ])->Pair(",")->Pair() eq ","');
+    is ($dd->Dump(), $want_comma, 'Perl: Data::Dumper->new([ $HASH ])->Pair(",")->Dump()');
+}