In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/fe642606b197643d481019a0cfe637837c580eff?hp=f1dcae2ca2c256c755eeec79c4e7d4d5b9cf658f>
- Log -----------------------------------------------------------------
commit fe642606b197643d481019a0cfe637837c580eff
Author: Father Chrysostomos <spr...@cpan.org>
Date: Mon Sep 6 23:41:01 2010 +1000
rt74170: test case that triggered the problem
M MANIFEST
M dist/Data-Dumper/t/dumper.t
A dist/Data-Dumper/t/perl-74170.t
commit e3ec2293dc1b98fee9c52af41dc25f8ab8ed3508
Author: Tony Cook <t...@develop-help.com>
Date: Mon Sep 6 23:40:24 2010 +1000
rt74170: handle the stack changing in the custom sort functions
Based on work by Father Chrysostomos <spr...@cpan.org>, but all
my fault.
M dist/Data-Dumper/Dumper.xs
-----------------------------------------------------------------------
Summary of changes:
MANIFEST | 1 +
dist/Data-Dumper/Dumper.xs | 2 +
dist/Data-Dumper/t/dumper.t | 11 +++-
dist/Data-Dumper/t/perl-74170.t | 143 +++++++++++++++++++++++++++++++++++++++
4 files changed, 156 insertions(+), 1 deletions(-)
create mode 100644 dist/Data-Dumper/t/perl-74170.t
diff --git a/MANIFEST b/MANIFEST
index 39e6cd9..6a55ead 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -2638,6 +2638,7 @@ dist/Data-Dumper/t/freezer.t See if
$Data::Dumper::Freezer works
dist/Data-Dumper/Todo Data pretty printer, futures
dist/Data-Dumper/t/overload.t See if Data::Dumper works for overloaded data
dist/Data-Dumper/t/pair.t See if Data::Dumper pair separator works
+dist/Data-Dumper/t/perl-74170.t Regression test for stack reallocation
dist/Data-Dumper/t/terse.t See if Data::Dumper terse option works
dist/ExtUtils-Install/Changes ExtUtils-Install change
log
dist/ExtUtils-Install/lib/ExtUtils/Installed.pm Information on
installed extensions
diff --git a/dist/Data-Dumper/Dumper.xs b/dist/Data-Dumper/Dumper.xs
index f2c1821..52a57f8 100644
--- a/dist/Data-Dumper/Dumper.xs
+++ b/dist/Data-Dumper/Dumper.xs
@@ -1188,10 +1188,12 @@ Data_Dumper_Dumpxs(href, ...)
else
newapad = apad;
+ PUTBACK;
DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr,
seenhv,
postav, &level, indent, pad, xpad, newapad, sep,
pair,
freezer, toaster, purity, deepcopy, quotekeys,
bless, maxdepth, sortkeys);
+ SPAGAIN;
if (indent >= 2 && !terse)
SvREFCNT_dec(newapad);
diff --git a/dist/Data-Dumper/t/dumper.t b/dist/Data-Dumper/t/dumper.t
index de5e87c..17a7466 100644
--- a/dist/Data-Dumper/t/dumper.t
+++ b/dist/Data-Dumper/t/dumper.t
@@ -83,7 +83,7 @@ sub SKIP_TEST {
$Data::Dumper::Useperl = 1;
if (defined &Data::Dumper::Dumpxs) {
print "### XS extension loaded, will run XS tests\n";
- $TMAX = 363; $XS = 1;
+ $TMAX = 366; $XS = 1;
}
else {
print "### XS extensions not loaded, will NOT run XS tests\n";
@@ -1429,4 +1429,13 @@ EOT
TEST q(Data::Dumper->Dumpxs([...@foo])) if $XS;
}
+############# 364
+# Make sure $obj->Dumpxs returns the right thing in list context. This was
+# broken by the initial attempt to fix [perl #74170].
+$WANT = <<'EOT';
+#$VAR1 = [];
+EOT
+TEST q(join " ", new Data::Dumper [[]],[] =>->Dumpxs),
+ '$obj->Dumpxs in list context'
+ if $XS;
diff --git a/dist/Data-Dumper/t/perl-74170.t b/dist/Data-Dumper/t/perl-74170.t
new file mode 100644
index 0000000..4f8025d
--- /dev/null
+++ b/dist/Data-Dumper/t/perl-74170.t
@@ -0,0 +1,143 @@
+#!perl -X
+#
+# Regression test for [perl #74170] (missing SPAGAIN after DD_Dump(...)):
+# Since itâs so large, it gets its own file.
+
+BEGIN {
+ 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;
+ }
+}
+
+use strict;
+use Test::More tests => 1;
+use Data::Dumper;
+
+our %repos = ();
+&real_life_setup();
+
+$Data::Dumper::Indent = 1;
+# A custom sort sub is necessary for reproducing the bug, as this is where
+# the stack gets reallocated.
+$Data::Dumper::Sortkeys = sub { return [ reverse sort keys %{$_[0]} ]; }
+ unless exists $ENV{NO_SORT_SUB};
+
+ok +Data::Dumper->Dumpxs([\%repos], [qw(*repos)]);
+
+sub real_life_setup {
+ # set up the %repos hash in a manner that reflects a real run of
+ # gitolite's "compiler" script:
+ # Yes, all this is necessary to get the stack in such a state that the
+ # custom sort sub will trigger a reallocation.
+ push @{ $repos{''}{'@all'} }, ();
+ push @{ $repos{''}{'guser86'} }, ();
+ push @{ $repos{''}{'guser87'} }, ();
+ push @{ $repos{''}{'user88'} }, ();
+ push @{ $repos{''}{'grussell'} }, ();
+ push @{ $repos{''}{'guser0'} }, ();
+ push @{ $repos{''}{'guser1'} }, ();
+ push @{ $repos{''}{'guser10'} }, ();
+ push @{ $repos{''}{'guser11'} }, ();
+ push @{ $repos{''}{'guser12'} }, ();
+ push @{ $repos{''}{'guser13'} }, ();
+ push @{ $repos{''}{'guser14'} }, ();
+ push @{ $repos{''}{'guser15'} }, ();
+ push @{ $repos{''}{'guser16'} }, ();
+ push @{ $repos{''}{'guser17'} }, ();
+ push @{ $repos{''}{'guser18'} }, ();
+ push @{ $repos{''}{'guser19'} }, ();
+ push @{ $repos{''}{'guser2'} }, ();
+ push @{ $repos{''}{'guser20'} }, ();
+ push @{ $repos{''}{'guser21'} }, ();
+ push @{ $repos{''}{'guser22'} }, ();
+ push @{ $repos{''}{'guser23'} }, ();
+ push @{ $repos{''}{'guser24'} }, ();
+ push @{ $repos{''}{'guser25'} }, ();
+ push @{ $repos{''}{'guser26'} }, ();
+ push @{ $repos{''}{'guser27'} }, ();
+ push @{ $repos{''}{'guser28'} }, ();
+ push @{ $repos{''}{'guser29'} }, ();
+ push @{ $repos{''}{'guser3'} }, ();
+ push @{ $repos{''}{'guser30'} }, ();
+ push @{ $repos{''}{'guser31'} }, ();
+ push @{ $repos{''}{'guser32'} }, ();
+ push @{ $repos{''}{'guser33'} }, ();
+ push @{ $repos{''}{'guser34'} }, ();
+ push @{ $repos{''}{'guser35'} }, ();
+ push @{ $repos{''}{'guser36'} }, ();
+ push @{ $repos{''}{'guser37'} }, ();
+ push @{ $repos{''}{'guser38'} }, ();
+ push @{ $repos{''}{'guser39'} }, ();
+ push @{ $repos{''}{'guser4'} }, ();
+ push @{ $repos{''}{'guser40'} }, ();
+ push @{ $repos{''}{'guser41'} }, ();
+ push @{ $repos{''}{'guser42'} }, ();
+ push @{ $repos{''}{'guser43'} }, ();
+ push @{ $repos{''}{'guser44'} }, ();
+ push @{ $repos{''}{'guser45'} }, ();
+ push @{ $repos{''}{'guser46'} }, ();
+ push @{ $repos{''}{'guser47'} }, ();
+ push @{ $repos{''}{'guser48'} }, ();
+ push @{ $repos{''}{'guser49'} }, ();
+ push @{ $repos{''}{'guser5'} }, ();
+ push @{ $repos{''}{'guser50'} }, ();
+ push @{ $repos{''}{'guser51'} }, ();
+ push @{ $repos{''}{'guser52'} }, ();
+ push @{ $repos{''}{'guser53'} }, ();
+ push @{ $repos{''}{'guser54'} }, ();
+ push @{ $repos{''}{'guser55'} }, ();
+ push @{ $repos{''}{'guser56'} }, ();
+ push @{ $repos{''}{'guser57'} }, ();
+ push @{ $repos{''}{'guser58'} }, ();
+ push @{ $repos{''}{'guser59'} }, ();
+ push @{ $repos{''}{'guser6'} }, ();
+ push @{ $repos{''}{'guser60'} }, ();
+ push @{ $repos{''}{'guser61'} }, ();
+ push @{ $repos{''}{'guser62'} }, ();
+ push @{ $repos{''}{'guser63'} }, ();
+ push @{ $repos{''}{'guser64'} }, ();
+ push @{ $repos{''}{'guser65'} }, ();
+ push @{ $repos{''}{'guser66'} }, ();
+ push @{ $repos{''}{'guser67'} }, ();
+ push @{ $repos{''}{'guser68'} }, ();
+ push @{ $repos{''}{'guser69'} }, ();
+ push @{ $repos{''}{'guser7'} }, ();
+ push @{ $repos{''}{'guser70'} }, ();
+ push @{ $repos{''}{'guser71'} }, ();
+ push @{ $repos{''}{'guser72'} }, ();
+ push @{ $repos{''}{'guser73'} }, ();
+ push @{ $repos{''}{'guser74'} }, ();
+ push @{ $repos{''}{'guser75'} }, ();
+ push @{ $repos{''}{'guser76'} }, ();
+ push @{ $repos{''}{'guser77'} }, ();
+ push @{ $repos{''}{'guser78'} }, ();
+ push @{ $repos{''}{'guser79'} }, ();
+ push @{ $repos{''}{'guser8'} }, ();
+ push @{ $repos{''}{'guser80'} }, ();
+ push @{ $repos{''}{'guser81'} }, ();
+ push @{ $repos{''}{'guser82'} }, ();
+ push @{ $repos{''}{'guser83'} }, ();
+ push @{ $repos{''}{'guser84'} }, ();
+ push @{ $repos{''}{'guser85'} }, ();
+ push @{ $repos{''}{'guser9'} }, ();
+ push @{ $repos{''}{'user1'} }, ();
+ push @{ $repos{''}{'user10'} }, ();
+ push @{ $repos{''}{'user11'} }, ();
+ push @{ $repos{''}{'user12'} }, ();
+ push @{ $repos{''}{'user13'} }, ();
+ push @{ $repos{''}{'user14'} }, ();
+ push @{ $repos{''}{'user15'} }, ();
+ push @{ $repos{''}{'user16'} }, ();
+ push @{ $repos{''}{'user2'} }, ();
+ push @{ $repos{''}{'user3'} }, ();
+ push @{ $repos{''}{'user4'} }, ();
+ push @{ $repos{''}{'user5'} }, ();
+ push @{ $repos{''}{'user6'} }, ();
+ push @{ $repos{''}{'user7'} }, ();
+ $repos{''}{R}{'user8'} = 1;
+ $repos{''}{W}{'user8'} = 1;
+ push @{ $repos{''}{'user8'} }, ();
+}
--
Perl5 Master Repository
