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

diff --git a/op.c b/op.c
index af7ec8b..75d7583 100644 (file)
--- a/op.c
+++ b/op.c
@@ -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 9574872..4186d82 100644 (file)
--- 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 448e399..0d13438 100644 (file)
--- 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

diff --git a/sv.c b/sv.c
index d4bc47e..3e5f1bd 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -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 44c7c04..c792bbb 100755 (executable)
--- 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";