diff options
author | Gurusamy Sarathy <gsar@engin.umich.edu> | 1997-05-08 20:04:18 -0400 |
---|---|---|
committer | Chip Salzenberg <chip@atlantic.net> | 1997-05-08 00:00:00 +1200 |
commit | e9e069932a0db06904b29e2b09a435afd40ed35c (patch) | |
tree | 72860dd0a183947dbf98cc8d6508993ae34d89aa | |
parent | eb447b8692d1c89cd24ab421497dcff667570be4 (diff) | |
download | perl-e9e069932a0db06904b29e2b09a435afd40ed35c.tar.gz |
Fix for redefined sort subs nastiness
>sub sortfunc { &once }
>sub once {
> eval q{
> print "Eval from ", join(':', caller(0)), "\n";
> sub rest {
> print "REST: $a <=> $b\n";
> $a <=> $b
> }
> };
> *sortfunc = *rest;
> &sortfunc;
>}
>@x = sort sortfunc 10, 5, 2.5, 1.25;
That misbehaves due to the redefinition of the sort sub
while the sort is active. That's a big no-no, because
the sortcop was pointing to the CvSTART of the original,
and it will now point to freed memory (if the sub really
got undefined).
Here's a tested patch that does nothing but die under
that circumstance.
p5p-msgid: 199705090004.UAA15032@aatma.engin.umich.edu
-rw-r--r-- | op.c | 3 | ||||
-rw-r--r-- | pod/perldelta.pod | 8 | ||||
-rw-r--r-- | pod/perldiag.pod | 8 | ||||
-rw-r--r-- | sv.c | 8 | ||||
-rwxr-xr-x | t/op/sort.t | 27 |
5 files changed, 53 insertions, 1 deletions
@@ -3232,6 +3232,9 @@ OP *block; SAVEFREESV(compcv); goto done; } + /* ahem, death to those who redefine active sort subs */ + if (curstack == sortstack && sortcop == CvSTART(cv)) + croak("Can't redefine active sort subroutine %s", name); const_sv = cv_const_sv(cv); if (const_sv || dowarn) { line_t oldline = curcop->cop_line; diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 9574872791..4186d829a4 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -1102,6 +1102,14 @@ dereference it first. See L<perlfunc/substr>. (F) Only hard references are allowed by "strict refs". Symbolic references are disallowed. See L<perlref>. +=item Can't redefine active sort subroutine %s + +(F) Perl optimizes the internal handling of sort subroutines and keeps +pointers into them. You tried to redefine one such sort subroutine when it +was currently active, which is not allowed. If you really wanted to do +this, you should wrap the subroutine with another one that does nothing +but call it, and use the wrapper as the sort subroutine. + =item Cannot resolve method `%s' overloading `%s' in package `%s' (P) Internal error trying to resolve overloading specified by a method diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 448e39909d..0d13438a99 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -688,6 +688,14 @@ couldn't open the pipe into which to send data destined for stdout. (F) The script you specified can't be opened for the indicated reason. +=item Can't redefine active sort subroutine %s + +(F) Perl optimizes the internal handling of sort subroutines and keeps +pointers into them. You tried to redefine one such sort subroutine when it +was currently active, which is not allowed. If you really wanted to do +this, you should wrap the subroutine with another one that does nothing +but call it, and use the wrapper as the sort subroutine. + =item Can't rename %s to %s: %s, skipping file (S) The rename done by the B<-i> switch failed for some reason, probably because @@ -1928,6 +1928,10 @@ register SV *sstr; GvNAMELEN(dstr) = len; SvFAKE_on(dstr); /* can coerce to non-glob */ } + /* ahem, death to those who redefine active sort subs */ + else if (curstack == sortstack + && GvCV(dstr) && sortcop == CvSTART(GvCV(dstr))) + croak("Can't redefine active sort subroutine %s", GvNAME(dstr)); (void)SvOK_off(dstr); GvINTRO_off(dstr); /* one-shot flag */ gp_free((GV*)dstr); @@ -2010,6 +2014,10 @@ register SV *sstr; if (!GvCVGEN((GV*)dstr) && (CvROOT(cv) || CvXSUB(cv))) { + /* ahem, death to those who redefine active sort subs */ + if (curstack == sortstack && sortcop == CvSTART(cv)) + croak("Can't redefine active sort subroutine %s", + GvENAME((GV*)dstr)); if (cv_const_sv(cv)) warn("Constant subroutine %s redefined", GvENAME((GV*)dstr)); diff --git a/t/op/sort.t b/t/op/sort.t index 44c7c04185..c792bbb48e 100755 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -2,7 +2,7 @@ # $RCSfile: sort.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:24 $ -print "1..14\n"; +print "1..19\n"; sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } @@ -66,3 +66,28 @@ print "# x = '@b'\n"; @b = sort reverse (4,1,3,2); print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n"); print "# x = '@b'\n"; + +$^W = 0; +# redefining sort sub inside the sort sub should fail +sub twoface { *twoface = sub { $a <=> $b }; &twoface } +eval { @b = sort twoface 4,1,3,2 }; +print ($@ =~ /redefine active sort/ ? "ok 15\n" : "not ok 15\n"); + +# redefining sort subs outside the sort should not fail +eval { *twoface = sub { &backwards } }; +print $@ ? "not ok 16\n" : "ok 16\n"; + +eval { @b = sort twoface 4,1,3,2 }; +print ("@b" eq '4 3 2 1' ? "ok 17\n" : "not ok 17 |@b|\n"); + +*twoface = sub { *twoface = *backwards; $a <=> $b }; +eval { @b = sort twoface 4,1 }; +print ($@ =~ /redefine active sort/ ? "ok 18\n" : "not ok 18\n"); + +*twoface = sub { + eval 'sub twoface { $a <=> $b }'; + die($@ =~ /redefine active sort/ ? "ok 19\n" : "not ok 19\n"); + $a <=> $b; + }; +eval { @b = sort twoface 4,1 }; +print $@ ? "$@" : "not ok 19\n"; |