From: Brian Ingerson Date: Sun, 30 Sep 2001 21:45:56 +0000 (-0700) Subject: Option to sort hashes X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e9105f86fac986145f3f944f90b0191d33cf4185;p=p5sagit%2Fp5-mst-13.2.git Option to sort hashes Message-ID: <20010930214556.D26392@ttul.org> (remember also the #12289) p4raw-id: //depot/perl@12288 --- diff --git a/ext/Data/Dumper/Dumper.xs b/ext/Data/Dumper/Dumper.xs index 8fc7ac3..d0eb917 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 bf07229..2371835 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; +}