From: Gurusamy Sarathy <gsar@engin.umich.edu>
Date: Fri, 9 May 1997 00:04:18 +0000 (-0400)
Subject: Fix for redefined sort subs nastiness
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e9e069932a0db06904b29e2b09a435afd40ed35c;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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
--- 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
--- 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
--- 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
--- 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";