Option to sort hashes

Message-ID: <20010930214556.D26392@ttul.org>

(remember also the #12289)

p4raw-id: //depot/perl@12288

2 files changed, 177 insertions, 16 deletions

diff --git a/ext/Data/Dumper/Dumper.xs b/ext/Data/Dumper/Dumper.xs
index 8fc7ac35a1..d0eb917b58 100644
--- a/ext/Data/Dumper/Dumper.xs
+++ b/ext/Data/Dumper/Dumper.xs
@@ -29,7 +29,7 @@ static I32 DD_dump (pTHX_ SV *val, char *name, STRLEN namelen, SV *retval,
 		    SV *pad, SV *xpad, SV *apad, SV *sep,
 		    SV *freezer, SV *toaster,
 		    I32 purity, I32 deepcopy, I32 quotekeys, SV *bless,
-		    I32 maxdepth);
+		    I32 maxdepth, SV *sortkeys);
 
 /* does a string need to be protected? */
 static I32
@@ -179,7 +179,7 @@ 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,
-	I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth)
+	I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys)
 {
     char tmpbuf[128];
     U32 i;
@@ -354,7 +354,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 		DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
 			postav, levelp,	indent, pad, xpad, apad, sep,
 			freezer, toaster, purity, deepcopy, quotekeys, bless,
-			maxdepth);
+			maxdepth, sortkeys);
 		sv_catpvn(retval, ")}", 2);
 	    }						     /* plain */
 	    else {
@@ -362,7 +362,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 		DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
 			postav, levelp,	indent, pad, xpad, apad, sep,
 			freezer, toaster, purity, deepcopy, quotekeys, bless,
-			maxdepth);
+			maxdepth, sortkeys);
 	    }
 	    SvREFCNT_dec(namesv);
 	}
@@ -374,7 +374,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 	    DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
 		    postav, levelp,	indent, pad, xpad, apad, sep,
 		    freezer, toaster, purity, deepcopy, quotekeys, bless,
-		    maxdepth);
+		    maxdepth, sortkeys);
 	    SvREFCNT_dec(namesv);
 	}
 	else if (realtype == SVt_PVAV) {
@@ -443,7 +443,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 		DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
 			levelp,	indent, pad, xpad, apad, sep,
 			freezer, toaster, purity, deepcopy, quotekeys, bless,
-			maxdepth);
+			maxdepth, sortkeys);
 		if (ix < ixmax)
 		    sv_catpvn(retval, ",", 1);
 	    }
@@ -468,6 +468,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 	    char *key;
 	    I32 klen;
 	    SV *hval;
+	    AV *keys = Nullav;
 	
 	    iname = newSVpvn(name, namelen);
 	    if (name[0] == '%') {
@@ -497,9 +498,42 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 	    sv_catsv(totpad, pad);
 	    sv_catsv(totpad, apad);
 	
-	    (void)hv_iterinit((HV*)ival);
+	    /* If requested, get a sorted/filtered array of hash keys */
+	    if (sortkeys) {
+		if (sortkeys == &PL_sv_yes) {
+		    keys = newAV();
+		    (void)hv_iterinit((HV*)ival);
+		    while (entry = hv_iternext((HV*)ival)) {
+			sv = hv_iterkeysv(entry);
+			SvREFCNT_inc(sv);
+			av_push(keys, sv);
+		    }
+		    sortsv(AvARRAY(keys), 
+			   av_len(keys)+1, 
+			   Perl_sv_cmp_locale);
+		}
+		else {
+		    dSP; ENTER; SAVETMPS; PUSHMARK(sp);
+		    XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
+		    i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
+		    SPAGAIN;
+		    if (i) {
+			sv = POPs;
+			if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
+			    keys = (AV*)SvREFCNT_inc(SvRV(sv));
+		    }
+		    if (! keys)
+			warn("Sortkeys subroutine did not return ARRAYREF\n");
+		    PUTBACK; FREETMPS; LEAVE;
+		}
+		if (keys)
+		    sv_2mortal((SV*)keys);
+	    }
+	    else
+		(void)hv_iterinit((HV*)ival);
 	    i = 0;
-	    while ((entry = hv_iternext((HV*)ival)))  {
+	    while (sortkeys ? (void*)(keys && (i <= av_len(keys))) : 
+			      (void*)((entry = hv_iternext((HV*)ival))) )		    {
 		char *nkey = NULL;
 		I32 nticks = 0;
 		SV* keysv;
@@ -508,9 +542,21 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 		
 		if (i)
 		    sv_catpvn(retval, ",", 1);
+
+		if (sortkeys) {
+		    char *key;
+		    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);
+		    hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
+		}
+		else {
+		    keysv = hv_iterkeysv(entry);
+		    hval = hv_iterval((HV*)ival, entry);
+		}
+
 		i++;
-		keysv = hv_iterkeysv(entry);
-		hval  = hv_iterval((HV*)ival, entry);
 
 		do_utf8 = DO_UTF8(keysv);
 		key = SvPV(keysv, keylen);
@@ -571,7 +617,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 		DD_dump(aTHX_ hval, SvPVX(sname), SvCUR(sname), retval, seenhv,
 			postav, levelp,	indent, pad, xpad, newapad, sep,
 			freezer, toaster, purity, deepcopy, quotekeys, bless,
-			maxdepth);
+			maxdepth, sortkeys);
 		SvREFCNT_dec(sname);
 		Safefree(nkey);
 		if (indent >= 2)
@@ -713,7 +759,8 @@ 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,
-				deepcopy, quotekeys, bless, maxdepth);
+				deepcopy, quotekeys, bless, maxdepth, 
+				sortkeys);
 			SvREFCNT_dec(e);
 		    }
 		}
@@ -776,7 +823,7 @@ Data_Dumper_Dumpxs(href, ...)
 	    I32 indent, terse, i, imax, postlen;
 	    SV **svp;
 	    SV *val, *name, *pad, *xpad, *apad, *sep, *varname;
-	    SV *freezer, *toaster, *bless;
+	    SV *freezer, *toaster, *bless, *sortkeys;
 	    I32 purity, deepcopy, quotekeys, maxdepth = 0;
 	    char tmpbuf[1024];
 	    I32 gimme = GIMME;
@@ -858,6 +905,17 @@ Data_Dumper_Dumpxs(href, ...)
 		    bless = *svp;
 		if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
 		    maxdepth = SvIV(*svp);
+		if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
+		    sortkeys = *svp;
+		    if (! SvTRUE(sortkeys))
+			sortkeys = NULL;
+		    else if (! (SvROK(sortkeys) &&
+				SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
+		    {
+			/* flag to use qsortsv() for sorting hash keys */	
+			sortkeys = &PL_sv_yes; 
+		    }
+		}
 		postav = newAV();
 
 		if (todumpav)
@@ -923,7 +981,7 @@ Data_Dumper_Dumpxs(href, ...)
 		    DD_dump(aTHX_ val, SvPVX(name), SvCUR(name), valstr, seenhv,
 			    postav, &level, indent, pad, xpad, newapad, sep,
 			    freezer, toaster, purity, deepcopy, quotekeys,
-			    bless, maxdepth);
+			    bless, maxdepth, sortkeys);
 		
 		    if (indent >= 2)
 			SvREFCNT_dec(newapad);
diff --git a/ext/Data/Dumper/t/dumper.t b/ext/Data/Dumper/t/dumper.t
index bf0722977f..2371835647 100755
--- a/ext/Data/Dumper/t/dumper.t
+++ b/ext/Data/Dumper/t/dumper.t
@@ -61,11 +61,11 @@ sub TEST {
 
 if (defined &Data::Dumper::Dumpxs) {
   print "### XS extension loaded, will run XS tests\n";
-  $TMAX = 192; $XS = 1;
+  $TMAX = 210; $XS = 1;
 }
 else {
   print "### XS extensions not loaded, will NOT run XS tests\n";
-  $TMAX = 96; $XS = 0;
+  $TMAX = 105; $XS = 0;
 }
 
 print "1..$TMAX\n";
@@ -821,3 +821,106 @@ EOT
   TEST q(Data::Dumper->Dumpxs([$a], ['a']));
 
 }
+
+{
+  $i = 0;
+  $a = { map { ("$_$_$_", ++$i) } 'I'..'Q' };
+  local $Data::Dumper::Sortkeys = 1;
+
+############# 193
+##
+  $WANT = <<'EOT';
+#$VAR1 = {
+#  III => 1,
+#  JJJ => 2,
+#  KKK => 3,
+#  LLL => 4,
+#  MMM => 5,
+#  NNN => 6,
+#  OOO => 7,
+#  PPP => 8,
+#  QQQ => 9
+#};
+EOT
+
+TEST q(Data::Dumper->new([$a])->Dump;);
+TEST q(Data::Dumper->new([$a])->Dumpxs;)
+	if $XS;
+}
+
+{
+  $i = 5;
+  $c = { map { (++$i, "$_$_$_") } 'I'..'Q' };
+  local $Data::Dumper::Sortkeys = \&sort199;
+  sub sort199 {
+    my $hash = shift;
+    return [ sort { $b <=> $a } keys %$hash ];
+  }
+
+############# 199
+##
+  $WANT = <<'EOT';
+#$VAR1 = {
+#  '14' => 'QQQ',
+#  '13' => 'PPP',
+#  '12' => 'OOO',
+#  '11' => 'NNN',
+#  '10' => 'MMM',
+#  '9' => 'LLL',
+#  '8' => 'KKK',
+#  '7' => 'JJJ',
+#  '6' => 'III'
+#};
+EOT
+
+TEST q(Data::Dumper->new([$c])->Dump;);
+TEST q(Data::Dumper->new([$c])->Dumpxs;)
+	if $XS;
+}
+
+{
+  $i = 5;
+  $c = { map { (++$i, "$_$_$_") } 'I'..'Q' };
+  $d = { reverse %$c };
+  local $Data::Dumper::Sortkeys = \&sort205;
+  sub sort205 {
+    my $hash = shift;
+    return [ 
+      $hash eq $c ? (sort { $a <=> $b } keys %$hash)
+		  : (reverse sort keys %$hash)
+    ];
+  }
+
+############# 205
+##
+  $WANT = <<'EOT';
+#$VAR1 = [
+#  {
+#    '6' => 'III',
+#    '7' => 'JJJ',
+#    '8' => 'KKK',
+#    '9' => 'LLL',
+#    '10' => 'MMM',
+#    '11' => 'NNN',
+#    '12' => 'OOO',
+#    '13' => 'PPP',
+#    '14' => 'QQQ'
+#  },
+#  {
+#    QQQ => '14',
+#    PPP => '13',
+#    OOO => '12',
+#    NNN => '11',
+#    MMM => '10',
+#    LLL => '9',
+#    KKK => '8',
+#    JJJ => '7',
+#    III => '6'
+#  }
+#];
+EOT
+
+TEST q(Data::Dumper->new([[$c, $d]])->Dump;);
+TEST q(Data::Dumper->new([[$c, $d]])->Dumpxs;)
+	if $XS;
+}