Front page | perl.perl5.porters |
Postings from April 2000
Re: [ID 20000331.003] Sort subroutine single nonsingle value
Thread Previous
From:
Gurusamy Sarathy
Date:
April 26, 2000 21:35
Subject:
Re: [ID 20000331.003] Sort subroutine single nonsingle value
Message ID:
200004270435.VAA02165@molotok.activestate.com
On Fri, 31 Mar 2000 13:11:28 +0200, Jan Pazdziora wrote:
>This is a bug report for perl from adelton@fi.muni.cz,
>generated with the help of perlbug 1.28 running under perl v5.6.0.
[...]
>Please consider this simple script
>
> sub czcmp
> { return 0; }
> sub czsort
> { sort { czcmp($a, $b); } @_; } ## this is line 4
> my @a = czsort(1, 2);
>
>The script fails with
>
> Sort subroutine didn't return single value at tst line 4.
>
>which IMHO shouldn't -- I simply declare a block and call
>a function there, but the sort somehow seems to catch that @_. If I call
>it with just czsort(1), the error is not there.
>
>Under 5.005_03 and previous, this code (taken from Cz::Sort module)
>works fine. It's simple to workaround it but I still think it is
>a bug, since nor perldelta nor perlfunc seem to suggest that this
>use of sort is not allowed.
Please try this patch.
Sarathy
gsar@activestate.com
-----------------------------------8<-----------------------------------
Change 5955 by gsar@auger on 2000/04/27 04:26:44
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)
Affected files ...
... //depot/perl/op.c#286 edit
... //depot/perl/t/op/sort.t#18 edit
Differences ...
==== //depot/perl/op.c#286 (text) ====
Index: perl/op.c
--- perl/op.c.~1~ Wed Apr 26 21:28:47 2000
+++ perl/op.c Wed Apr 26 21:28:47 2000
@@ -5995,6 +5995,7 @@
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 @@
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 @@
}
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;
}
==== //depot/perl/t/op/sort.t#18 (xtext) ====
Index: perl/t/op/sort.t
--- perl/t/op/sort.t.~1~ Wed Apr 26 21:28:47 2000
+++ perl/t/op/sort.t Wed Apr 26 21:28:47 2000
@@ -5,7 +5,7 @@
unshift @INC, '../lib';
}
use warnings;
-print "1..49\n";
+print "1..55\n";
# XXX known to leak scalars
{
@@ -270,3 +270,36 @@
@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();
End of Patch.
Thread Previous