From 2b301921ff7682e54ab74ad30dbf2ce1c9fc24b1 Mon Sep 17 00:00:00 2001 From: Yves Orton Date: Fri, 31 Jan 2020 15:34:48 +0100 Subject: [PATCH] pp_sort.c: fix fencepost error in call to av_extend() MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit In [rt.cpan.org #39196] issue #17496 there is a report that Tie::File produced spurious blank lines in the file after @tied= sort @tied; it turns out that this is because Tie::File treats EXTEND similarly to STORESIZE (which is arguably not entirely correct, but also not that weird) coupled with an off by one error in the calls to av_extend() in pp_sort. This patch fixes the fencepost error, adds some comments to av_extend() to make it clear what it is doing, and adds a test that EXTEND is called by this code with correct argument. Signed-off-by: Petr Písař --- av.c | 18 ++++++++++++++++-- pp_sort.c | 5 +++-- t/op/sort.t | 23 +++++++++++++++++++++-- 3 files changed, 40 insertions(+), 6 deletions(-) diff --git a/av.c b/av.c index 918844c376..27b2f12032 100644 --- a/av.c +++ b/av.c @@ -55,8 +55,13 @@ Perl_av_reify(pTHX_ AV *av) /* =for apidoc av_extend -Pre-extend an array. The C is the index to which the array should be -extended. +Pre-extend an array so that it is capable of storing values at indexes +C<0..key>. Thus C guarantees that the array can store 100 +elements, i.e. that C through C +on a plain array will work without any further memory allocation. + +If the av argument is a tied array then will call the C tied +array method with an argument of C<(key+1)>. =cut */ @@ -72,6 +77,15 @@ Perl_av_extend(pTHX_ AV *av, SSize_t key) mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied); if (mg) { SV *arg1 = sv_newmortal(); + /* NOTE: the API for av_extend() is NOT the same as the tie method EXTEND. + * + * The C function takes an *index* (assumes 0 indexed arrays) and ensures + * that the array is at least as large as the index provided. + * + * The tied array method EXTEND takes a *count* and ensures that the array + * is at least that many elements large. Thus we have to +1 the key when + * we call the tied method. + */ sv_setiv(arg1, (IV)(key + 1)); Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(EXTEND), G_DISCARD, 1, arg1); diff --git a/pp_sort.c b/pp_sort.c index 0c5efb0869..4f81aaab7e 100644 --- a/pp_sort.c +++ b/pp_sort.c @@ -1067,7 +1067,8 @@ PP(pp_sort) for (i = 0; i < max; i++) base[i] = newSVsv(base[i]); av_clear(av); - av_extend(av, max); + if (max) + av_extend(av, max-1); for (i=0; i < max; i++) { SV * const sv = base[i]; SV ** const didstore = av_store(av, i, sv); @@ -1094,7 +1095,7 @@ PP(pp_sort) } av_clear(av); if (max > 0) { - av_extend(av, max); + av_extend(av, max-1); Copy(base, AvARRAY(av), max, SV*); } AvFILLp(av) = max - 1; diff --git a/t/op/sort.t b/t/op/sort.t index d201f00afd..f2e139dff0 100644 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -7,7 +7,8 @@ BEGIN { set_up_inc('../lib'); } use warnings; -plan(tests => 199); +plan(tests => 203); +use Tie::Array; # we need to test sorting tied arrays # these shouldn't hang { @@ -433,7 +434,6 @@ cmp_ok($x,'eq','123',q(optimized-away comparison block doesn't take any other ar @a = qw(b c a); $r1 = \$a[1]; @a = sort mysort @a; $r2 = \$a[0]; is "$$r1-$$r2-@a", "c-c-c b a", "inplace sort with function of lexical"; - use Tie::Array; my @t; tie @t, 'Tie::StdArray'; @@ -494,6 +494,25 @@ cmp_ok($x,'eq','123',q(optimized-away comparison block doesn't take any other ar is ("@a", "3 4 5", "RT #128340"); } +{ + @Tied_Array_EXTEND_Test::ISA= 'Tie::StdArray'; + my $extend_count; + sub Tied_Array_EXTEND_Test::EXTEND { + $extend_count= $_[1]; + return; + } + my @t; + tie @t, "Tied_Array_EXTEND_Test"; + is($extend_count, undef, "test that EXTEND has not been called prior to initialization"); + $t[0]=3; + $t[1]=1; + $t[2]=2; + is($extend_count, undef, "test that EXTEND has not been called during initialization"); + @t= sort @t; + is($extend_count, 3, "test that EXTEND was called with an argument of 3 by pp_sort()"); + is("@t","1 2 3","test that sorting the tied array worked even though EXTEND is a no-op"); +} + # Test optimisations of reversed sorts. As we now guarantee stability by # default, # optimisations which do not provide this are bogus. -- 2.21.1