From: chocolateboy <chocolateboy@chocolatey.com>
Date: Sat, 22 Feb 2003 12:17:28 +0000 (+0000)
Subject: Patch for Data::Dumper 2.12 to Allow Custom Hash Key/Value Separator
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=30b4f38607fd824e698ead42ae0a9819f52d0a51;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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
--- 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
--- 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
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()');
+}