allow XSUBs and prototyped subroutines to be used with sort() (tweaked

variant of patch suggested by Peter Haworth <pmh@edison.ioppublishing.com>)

p4raw-id: //depot/perl@4614

4 files changed, 221 insertions, 60 deletions

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index e46df77f83..12d26841a1 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -469,6 +469,16 @@ this support (if it is available).
 You can Configure -Dusemorebits to turn on both the 64-bit support
 and the long double support.
 
+=head2 Enhanced support for sort() subroutines
+
+Perl subroutines with a prototype of C<($$)> and XSUBs in general can
+now be used as sort subroutines.  In either case, the two elements to
+be compared as passed as normal parameters in @_.  See L<perlfunc/sort>.
+
+For unprototyped sort subroutines, the historical behavior of passing 
+the elements to be compared as the global variables $a and $b remains
+unchanged.
+
 =head2 Better syntax checks on parenthesized unary operators
 
 Expressions such as:
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 513cf7cdc6..7cf4d3fd0a 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -3941,12 +3941,16 @@ the name of (or a reference to) the actual subroutine to use.  In place
 of a SUBNAME, you can provide a BLOCK as an anonymous, in-line sort
 subroutine.
 
-In the interests of efficiency the normal calling code for subroutines is
-bypassed, with the following effects: the subroutine may not be a
-recursive subroutine, and the two elements to be compared are passed into
-the subroutine not via C<@_> but as the package global variables $a and
-$b (see example below).  They are passed by reference, so don't
-modify $a and $b.  And don't try to declare them as lexicals either.
+If the subroutine's prototype is C<($$)>, the elements to be compared
+are passed by reference in C<@_>, as for a normal subroutine.  If not,
+the normal calling code for subroutines is bypassed in the interests of
+efficiency, and the elements to be compared are passed into the subroutine
+as the package global variables $a and $b (see example below).  Note that
+in the latter case, it is usually counter-productive to declare $a and
+$b as lexicals.
+
+In either case, the subroutine may not be recursive.  The values to be
+compared are always passed by reference, so don't modify them.
 
 You also cannot exit out of the sort block or subroutine using any of the
 loop control operators described in L<perlsyn> or with C<goto>.
@@ -4026,6 +4030,14 @@ Examples:
                            ||
                   $a->[2] cmp $b->[2]
            } map { [$_, /=(\d+)/, uc($_)] } @old;
+    
+    # using a prototype allows you to use any comparison subroutine
+    # as a sort subroutine (including other package's subroutines)
+    package other;
+    sub backwards ($$) { $_[1] cmp $_[0]; }	# $a and $b are not set here
+
+    package main;
+    @new = sort other::backwards @old;
 
 If you're using strict, you I<must not> declare $a
 and $b as lexicals.  They are package globals.  That means
diff --git a/pp_ctl.c b/pp_ctl.c
index ec7dfb884a..54bd65438b 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -27,6 +27,8 @@
 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
 
 static I32 sortcv(pTHXo_ SV *a, SV *b);
+static I32 sortcv_stacked(pTHXo_ SV *a, SV *b);
+static I32 sortcv_xsub(pTHXo_ SV *a, SV *b);
 static I32 sv_ncmp(pTHXo_ SV *a, SV *b);
 static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b);
 static I32 amagic_ncmp(pTHXo_ SV *a, SV *b);
@@ -778,6 +780,8 @@ PP(pp_sort)
     I32 gimme = GIMME;
     OP* nextop = PL_op->op_next;
     I32 overloading = 0;
+    bool hasargs = FALSE;
+    I32 is_xsub = 0;
 
     if (gimme != G_ARRAY) {
 	SP = MARK;
@@ -796,28 +800,38 @@ PP(pp_sort)
 	}
 	else {
 	    cv = sv_2cv(*++MARK, &stash, &gv, 0);
+	    if (cv && SvPOK(cv)) {
+		STRLEN n_a;
+		char *proto = SvPV((SV*)cv, n_a);
+		if (proto && strEQ(proto, "$$")) {
+		    hasargs = TRUE;
+		}
+	    }
 	    if (!(cv && CvROOT(cv))) {
-		if (gv) {
+		if (cv && CvXSUB(cv)) {
+		    is_xsub = 1;
+		}
+		else if (gv) {
 		    SV *tmpstr = sv_newmortal();
 		    gv_efullname3(tmpstr, gv, Nullch);
-		    if (cv && CvXSUB(cv))
-			DIE(aTHX_ "Xsub \"%s\" called in sort", SvPVX(tmpstr));
 		    DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
 			SvPVX(tmpstr));
 		}
-		if (cv) {
-		    if (CvXSUB(cv))
-			DIE(aTHX_ "Xsub called in sort");
+		else {
 		    DIE(aTHX_ "Undefined subroutine in sort");
 		}
-		DIE(aTHX_ "Not a CODE reference in sort");
 	    }
-	    PL_sortcop = CvSTART(cv);
-	    SAVEVPTR(CvROOT(cv)->op_ppaddr);
-	    CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
 
-	    SAVEVPTR(PL_curpad);
-	    PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
+	    if (is_xsub)
+		PL_sortcop = (OP*)cv;
+	    else {
+		PL_sortcop = CvSTART(cv);
+		SAVEVPTR(CvROOT(cv)->op_ppaddr);
+		CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
+
+		SAVEVPTR(PL_curpad);
+		PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
+            }
 	}
     }
     else {
@@ -863,7 +877,6 @@ PP(pp_sort)
 
 	    PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
 	    if (!(PL_op->op_flags & OPf_SPECIAL)) {
-		bool hasargs = FALSE;
 		cx->cx_type = CXt_SUB;
 		cx->blk_gimme = G_SCALAR;
 		PUSHSUB(cx);
@@ -871,7 +884,19 @@ PP(pp_sort)
 		    (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
 	    }
 	    PL_sortcxix = cxstack_ix;
-	    qsortsv((myorigmark+1), max, sortcv);
+
+	    if (hasargs && !is_xsub) {
+		/* This is mostly copied from pp_entersub */
+		AV *av = (AV*)PL_curpad[0];
+
+#ifndef USE_THREADS
+		cx->blk_sub.savearray = GvAV(PL_defgv);
+		GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
+#endif /* USE_THREADS */
+		cx->blk_sub.argarray = av;
+	    }
+	    qsortsv((myorigmark+1), max,
+		    is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
 
 	    POPBLOCK(cx,PL_curpm);
 	    PL_stack_sp = newsp;
@@ -4148,6 +4173,74 @@ sortcv(pTHXo_ SV *a, SV *b)
     return result;
 }
 
+static I32
+sortcv_stacked(pTHXo_ SV *a, SV *b)
+{
+    dTHR;
+    I32 oldsaveix = PL_savestack_ix;
+    I32 oldscopeix = PL_scopestack_ix;
+    I32 result;
+    AV *av = GvAV(PL_defgv);
+
+    if (AvMAX(av) < 1) {
+	SV** ary = AvALLOC(av);
+	if (AvARRAY(av) != ary) {
+	    AvMAX(av) += AvARRAY(av) - AvALLOC(av);
+	    SvPVX(av) = (char*)ary;
+	}
+	if (AvMAX(av) < 1) {
+	    AvMAX(av) = 1;
+	    Renew(ary,2,SV*);
+	    SvPVX(av) = (char*)ary;
+	}
+    }
+    AvFILLp(av) = 1;
+
+    AvARRAY(av)[0] = a;
+    AvARRAY(av)[1] = b;
+    PL_stack_sp = PL_stack_base;
+    PL_op = PL_sortcop;
+    CALLRUNOPS(aTHX);
+    if (PL_stack_sp != PL_stack_base + 1)
+	Perl_croak(aTHX_ "Sort subroutine didn't return single value");
+    if (!SvNIOKp(*PL_stack_sp))
+	Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
+    result = SvIV(*PL_stack_sp);
+    while (PL_scopestack_ix > oldscopeix) {
+	LEAVE;
+    }
+    leave_scope(oldsaveix);
+    return result;
+}
+
+static I32
+sortcv_xsub(pTHXo_ SV *a, SV *b)
+{
+    dSP;
+    I32 oldsaveix = PL_savestack_ix;
+    I32 oldscopeix = PL_scopestack_ix;
+    I32 result;
+    CV *cv=(CV*)PL_sortcop;
+
+    SP = PL_stack_base;
+    PUSHMARK(SP);
+    EXTEND(SP, 2);
+    *++SP = a;
+    *++SP = b;
+    PUTBACK;
+    (void)(*CvXSUB(cv))(aTHXo_ cv);
+    if (PL_stack_sp != PL_stack_base + 1)
+	Perl_croak(aTHX_ "Sort subroutine didn't return single value");
+    if (!SvNIOKp(*PL_stack_sp))
+	Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
+    result = SvIV(*PL_stack_sp);
+    while (PL_scopestack_ix > oldscopeix) {
+	LEAVE;
+    }
+    leave_scope(oldsaveix);
+    return result;
+}
+
 
 static I32
 sv_ncmp(pTHXo_ SV *a, SV *b)
diff --git a/t/op/sort.t b/t/op/sort.t
index 9abc4105d2..6e3d2ca8e0 100755
--- a/t/op/sort.t
+++ b/t/op/sort.t
@@ -4,12 +4,13 @@ BEGIN {
     chdir 't' if -d 't';
     unshift @INC, '../lib';
 }
-print "1..38\n";
+print "1..49\n";
 
 # XXX known to leak scalars
 $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
 
 sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 }
+sub backwards_stacked($$) { my($a,$b) = @_; $a lt $b ? 1 : $a gt $b ? -1 : 0 }
 
 my $upperfirst = 'A' lt 'a';
 
@@ -40,96 +41,107 @@ $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
 print "# 2: x = '$x', expected = '$expected'\n";
 print ($x eq $expected ? "ok 2\n" : "not ok 2\n");
 
+$x = join('', sort( backwards_stacked @harry));
+$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
+print "# 3: x = '$x', expected = '$expected'\n";
+print ($x eq $expected ? "ok 3\n" : "not ok 3\n");
+
 $x = join('', sort @george, 'to', @harry);
 $expected = $upperfirst ?
     'AbelAxedCaincatchaseddoggonepunishedtoxyz' :
     'catchaseddoggonepunishedtoxyzAbelAxedCain' ;
-print "# 3: x = '$x', expected = '$expected'\n";
-print ($x eq $expected ?"ok 3\n":"not ok 3\n");
+print "# 4: x = '$x', expected = '$expected'\n";
+print ($x eq $expected ?"ok 4\n":"not ok 4\n");
 
 @a = ();
 @b = reverse @a;
-print ("@b" eq "" ? "ok 4\n" : "not ok 4 (@b)\n");
+print ("@b" eq "" ? "ok 5\n" : "not ok 5 (@b)\n");
 
 @a = (1);
 @b = reverse @a;
-print ("@b" eq "1" ? "ok 5\n" : "not ok 5 (@b)\n");
+print ("@b" eq "1" ? "ok 6\n" : "not ok 6 (@b)\n");
 
 @a = (1,2);
 @b = reverse @a;
-print ("@b" eq "2 1" ? "ok 6\n" : "not ok 6 (@b)\n");
+print ("@b" eq "2 1" ? "ok 7\n" : "not ok 7 (@b)\n");
 
 @a = (1,2,3);
 @b = reverse @a;
-print ("@b" eq "3 2 1" ? "ok 7\n" : "not ok 7 (@b)\n");
+print ("@b" eq "3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n");
 
 @a = (1,2,3,4);
 @b = reverse @a;
-print ("@b" eq "4 3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n");
+print ("@b" eq "4 3 2 1" ? "ok 9\n" : "not ok 9 (@b)\n");
 
 @a = (10,2,3,4);
 @b = sort {$a <=> $b;} @a;
-print ("@b" eq "2 3 4 10" ? "ok 9\n" : "not ok 9 (@b)\n");
+print ("@b" eq "2 3 4 10" ? "ok 10\n" : "not ok 10 (@b)\n");
 
 $sub = 'backwards';
 $x = join('', sort $sub @harry);
 $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
-print "# 10: x = $x, expected = '$expected'\n";
-print ($x eq $expected ? "ok 10\n" : "not ok 10\n");
+print "# 11: x = $x, expected = '$expected'\n";
+print ($x eq $expected ? "ok 11\n" : "not ok 11\n");
+
+$sub = 'backwards_stacked';
+$x = join('', sort $sub @harry);
+$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
+print "# 12: x = $x, expected = '$expected'\n";
+print ($x eq $expected ? "ok 12\n" : "not ok 12\n");
 
 # literals, combinations
 
 @b = sort (4,1,3,2);
-print ("@b" eq '1 2 3 4' ? "ok 11\n" : "not ok 11\n");
+print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n");
 print "# x = '@b'\n";
 
 @b = sort grep { $_ } (4,1,3,2);
-print ("@b" eq '1 2 3 4' ? "ok 12\n" : "not ok 12\n");
+print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n");
 print "# x = '@b'\n";
 
 @b = sort map { $_ } (4,1,3,2);
-print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n");
+print ("@b" eq '1 2 3 4' ? "ok 15\n" : "not ok 15\n");
 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 ("@b" eq '1 2 3 4' ? "ok 16\n" : "not ok 16\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");
+print ($@ =~ /redefine active sort/ ? "ok 17\n" : "not ok 17\n");
 
 # redefining sort subs outside the sort should not fail
 eval { *twoface = sub { &backwards } };
-print $@ ? "not ok 16\n" : "ok 16\n";
+print $@ ? "not ok 18\n" : "ok 18\n";
 
 eval { @b = sort twoface 4,1,3,2 };
-print ("@b" eq '4 3 2 1' ? "ok 17\n" : "not ok 17 |@b|\n");
+print ("@b" eq '4 3 2 1' ? "ok 19\n" : "not ok 19 |@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");
+print ($@ =~ /redefine active sort/ ? "ok 20\n" : "not ok 20\n");
 
 *twoface = sub {
                  eval 'sub twoface { $a <=> $b }';
-		 die($@ =~ /redefine active sort/ ? "ok 19\n" : "not ok 19\n");
+		 die($@ =~ /redefine active sort/ ? "ok 21\n" : "not ok 21\n");
 		 $a <=> $b;
 	       };
 eval { @b = sort twoface 4,1 };
-print $@ ? "$@" : "not ok 19\n";
+print $@ ? "$@" : "not ok 21\n";
 
 eval <<'CODE';
     my @result = sort main'backwards 'one', 'two';
 CODE
-print $@ ? "not ok 20\n# $@" : "ok 20\n";
+print $@ ? "not ok 22\n# $@" : "ok 22\n";
 
 eval <<'CODE';
     # "sort 'one', 'two'" should not try to parse "'one" as a sort sub
     my @result = sort 'one', 'two';
 CODE
-print $@ ? "not ok 21\n# $@" : "ok 21\n";
+print $@ ? "not ok 23\n# $@" : "ok 23\n";
 
 {
   my $sortsub = \&backwards;
@@ -137,13 +149,28 @@ print $@ ? "not ok 21\n# $@" : "ok 21\n";
   my $sortglobr = \*backwards;
   my $sortname = 'backwards';
   @b = sort $sortsub 4,1,3,2;
-  print ("@b" eq '4 3 2 1' ? "ok 22\n" : "not ok 22 |@b|\n");
+  print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n");
   @b = sort $sortglob 4,1,3,2;
-  print ("@b" eq '4 3 2 1' ? "ok 23\n" : "not ok 23 |@b|\n");
+  print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n");
   @b = sort $sortname 4,1,3,2;
-  print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n");
+  print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n");
   @b = sort $sortglobr 4,1,3,2;
-  print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n");
+  print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n");
+}
+
+{
+  my $sortsub = \&backwards_stacked;
+  my $sortglob = *backwards_stacked;
+  my $sortglobr = \*backwards_stacked;
+  my $sortname = 'backwards_stacked';
+  @b = sort $sortsub 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n");
+  @b = sort $sortglob 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n");
+  @b = sort $sortname 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 30\n" : "not ok 30 |@b|\n");
+  @b = sort $sortglobr 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 31\n" : "not ok 31 |@b|\n");
 }
 
 {
@@ -152,13 +179,28 @@ print $@ ? "not ok 21\n# $@" : "ok 21\n";
   local $sortglobr = \*backwards;
   local $sortname = 'backwards';
   @b = sort $sortsub 4,1,3,2;
-  print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n");
+  print ("@b" eq '4 3 2 1' ? "ok 32\n" : "not ok 32 |@b|\n");
   @b = sort $sortglob 4,1,3,2;
-  print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n");
+  print ("@b" eq '4 3 2 1' ? "ok 33\n" : "not ok 33 |@b|\n");
   @b = sort $sortname 4,1,3,2;
-  print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n");
+  print ("@b" eq '4 3 2 1' ? "ok 34\n" : "not ok 34 |@b|\n");
   @b = sort $sortglobr 4,1,3,2;
-  print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n");
+  print ("@b" eq '4 3 2 1' ? "ok 35\n" : "not ok 35 |@b|\n");
+}
+
+{
+  local $sortsub = \&backwards_stacked;
+  local $sortglob = *backwards_stacked;
+  local $sortglobr = \*backwards_stacked;
+  local $sortname = 'backwards_stacked';
+  @b = sort $sortsub 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 36\n" : "not ok 36 |@b|\n");
+  @b = sort $sortglob 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 37\n" : "not ok 37 |@b|\n");
+  @b = sort $sortname 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 38\n" : "not ok 38 |@b|\n");
+  @b = sort $sortglobr 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 39\n" : "not ok 39 |@b|\n");
 }
 
 ## exercise sort builtins... ($a <=> $b already tested)
@@ -167,42 +209,46 @@ print $@ ? "not ok 21\n# $@" : "ok 21\n";
     my $dummy;		# force blockness
     return $b <=> $a
 } @a;
-print ("@b" eq '1996 255 90 19 5' ? "ok 30\n" : "not ok 30\n");
+print ("@b" eq '1996 255 90 19 5' ? "ok 40\n" : "not ok 40\n");
 print "# x = '@b'\n";
 $x = join('', sort { $a cmp $b } @harry);
 $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain';
-print ($x eq $expected ? "ok 31\n" : "not ok 31\n");
+print ($x eq $expected ? "ok 41\n" : "not ok 41\n");
 print "# x = '$x'; expected = '$expected'\n";
 $x = join('', sort { $b cmp $a } @harry);
 $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
-print ($x eq $expected ? "ok 32\n" : "not ok 32\n");
+print ($x eq $expected ? "ok 42\n" : "not ok 42\n");
 print "# x = '$x'; expected = '$expected'\n";
 {
     use integer;
     @b = sort { $a <=> $b } @a;
-    print ("@b" eq '5 19 90 255 1996' ? "ok 33\n" : "not ok 33\n");
+    print ("@b" eq '5 19 90 255 1996' ? "ok 43\n" : "not ok 43\n");
     print "# x = '@b'\n";
     @b = sort { $b <=> $a } @a;
-    print ("@b" eq '1996 255 90 19 5' ? "ok 34\n" : "not ok 34\n");
+    print ("@b" eq '1996 255 90 19 5' ? "ok 44\n" : "not ok 44\n");
     print "# x = '@b'\n";
     $x = join('', sort { $a cmp $b } @harry);
     $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain';
-    print ($x eq $expected ? "ok 35\n" : "not ok 35\n");
+    print ($x eq $expected ? "ok 45\n" : "not ok 45\n");
     print "# x = '$x'; expected = '$expected'\n";
     $x = join('', sort { $b cmp $a } @harry);
     $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
-    print ($x eq $expected ? "ok 36\n" : "not ok 36\n");
+    print ($x eq $expected ? "ok 46\n" : "not ok 46\n");
     print "# x = '$x'; expected = '$expected'\n";
 }
 
 # test that an optimized-away comparison block doesn't take any other
 # arguments away with it
 $x = join('', sort { $a <=> $b } 3, 1, 2);
-print $x eq "123" ? "ok 37\n" : "not ok 37\n";
+print $x eq "123" ? "ok 47\n" : "not ok 47\n";
 
 # test sorting in non-main package
 package Foo;
 @a = ( 5, 19, 1996, 255, 90 );
 @b = sort { $b <=> $a } @a;
-print ("@b" eq '1996 255 90 19 5' ? "ok 38\n" : "not ok 38\n");
+print ("@b" eq '1996 255 90 19 5' ? "ok 48\n" : "not ok 48\n");
+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";