From: Gurusamy Sarathy <gsar@cpan.org>
Date: Thu, 27 Apr 2000 04:26:44 +0000 (+0000)
Subject: longstanding bug exposed by change#3307: sort arguments weren't
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8e3f9bdf33f266c6e827493ca82149fc1598579a;p=p5sagit%2Fp5-mst-13.2.git

longstanding bug exposed by change#3307: sort arguments weren't
compiled with the right wantarray context (ensuing runtime lookup
via block_gimme() was getting the incidental context of the
sort() itself)

p4raw-link: @3307 on //depot/perl: 82092f1dcd6e496644fe74540fa706cb390be431

p4raw-id: //depot/perl@5955
---

diff --git a/op.c b/op.c
index 64b8006..95aa4f2 100644
--- a/op.c
+++ b/op.c
@@ -5995,6 +5995,7 @@ Perl_ck_shift(pTHX_ OP *o)
 OP *
 Perl_ck_sort(pTHX_ OP *o)
 {
+    OP *firstkid;
     o->op_private = 0;
 #ifdef USE_LOCALE
     if (PL_hints & HINT_LOCALE)
@@ -6003,10 +6004,10 @@ Perl_ck_sort(pTHX_ OP *o)
 
     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
 	simplify_sort(o);
-    if (o->op_flags & OPf_STACKED) {		     /* may have been cleared */
-	OP *kid = cLISTOPo->op_first->op_sibling;	/* get past pushmark */
+    firstkid = cLISTOPo->op_first->op_sibling;		/* get past pushmark */
+    if (o->op_flags & OPf_STACKED) {			/* may have been cleared */
 	OP *k;
-	kid = kUNOP->op_first;				/* get past null */
+	OP *kid = cUNOPx(firstkid)->op_first;		/* get past null */
 
 	if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
 	    linklist(kid);
@@ -6036,17 +6037,26 @@ Perl_ck_sort(pTHX_ OP *o)
 	    }
 	    peep(k);
 
-	    kid = cLISTOPo->op_first->op_sibling;	/* get past pushmark */
-	    if (o->op_type == OP_SORT)
+	    kid = firstkid;
+	    if (o->op_type == OP_SORT) {
+		/* provide scalar context for comparison function/block */
+		kid = scalar(kid);
 		kid->op_next = kid;
+	    }
 	    else
 		kid->op_next = k;
 	    o->op_flags |= OPf_SPECIAL;
 	}
 	else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
-	    null(cLISTOPo->op_first->op_sibling);
+	    null(firstkid);
+
+	firstkid = firstkid->op_sibling;
     }
 
+    /* provide list context for arguments */
+    if (o->op_type == OP_SORT)
+	list(firstkid);
+
     return o;
 }
 
diff --git a/t/op/sort.t b/t/op/sort.t
index ba0a4c2..00b2dac 100755
--- a/t/op/sort.t
+++ b/t/op/sort.t
@@ -5,7 +5,7 @@ BEGIN {
     unshift @INC, '../lib';
 }
 use warnings;
-print "1..49\n";
+print "1..55\n";
 
 # XXX known to leak scalars
 {
@@ -270,3 +270,36 @@ print "# x = '@b'\n";
 @b = sort main::Backwards_stacked @a;
 print ("@b" eq '90 5 255 1996 19' ? "ok 49\n" : "not ok 49\n");
 print "# x = '@b'\n";
+
+# check if context for sort arguments is handled right
+
+$test = 49;
+sub test_if_list {
+    my $gimme = wantarray;
+    print "not " unless $gimme;
+    ++$test;
+    print "ok $test\n";
+}
+my $m = sub { $a <=> $b };
+
+sub cxt_one { sort $m test_if_list() }
+cxt_one();
+sub cxt_two { sort { $a <=> $b } test_if_list() }
+cxt_two();
+sub cxt_three { sort &test_if_list() }
+cxt_three();
+
+sub test_if_scalar {
+    my $gimme = wantarray;
+    print "not " if $gimme or !defined($gimme);
+    ++$test;
+    print "ok $test\n";
+}
+
+$m = \&test_if_scalar;
+sub cxt_four { sort $m 1,2 }
+@x = cxt_four();
+sub cxt_five { sort { test_if_scalar($a,$b); } 1,2 }
+@x = cxt_five();
+sub cxt_six { sort test_if_scalar 1,2 }
+@x = cxt_six();