From: Father Chrysostomos <sprout@cpan.org>
Date: Sat, 15 Oct 2011 21:05:33 +0000 (-0700)
Subject: Make XS sort routines work again
X-Git-Tag: v5.15.4~49
X-Git-Url: https://perl5.git.perl.org/perl5.git/commitdiff_plain/2fc49ef14c391f64250e0f99fbbed2007b880289

Make XS sort routines work again

These stopped working when the CvROOT and CvXSUB fields were merged
in 5.10.0:

$ perl5.8.9 -le 'print sort utf8::is_utf8 2,1'
Usage: utf8::is_utf8(sv) at -e line 1.
$ perl5.10.0 -le 'print sort utf8::is_utf8 2,1'
12

(In the latter case, the utf8::is_utf8 routine is not being called.)

pp_sort has this:

	    if (!(cv && CvROOT(cv))) {
		if (cv && CvISXSUB(cv)) {

But CvROOT is the same as CvXSUB, so that block is never entered for
XSUBs, so this piece of code later on:

	    if (is_xsub)
		PL_sortcop = (OP*)cv;
	    else
		PL_sortcop = CvSTART(cv);

sets PL_sortcop to CvSTART for XSUBs, but CvSTART is NULL.  Later on,
this if condition fails:

	if (PL_sortcop) {

so the XSUB is treated as being absent.
---

diff --git a/MANIFEST b/MANIFEST
index a01e94b..ce44f46 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3867,6 +3867,7 @@ ext/XS-APItest/t/rmagical.t	XS::APItest extension
 ext/XS-APItest/t/rv2cv_op_cv.t	test rv2cv_op_cv() API
 ext/XS-APItest/t/savehints.t	test SAVEHINTS() API
 ext/XS-APItest/t/scopelessblock.t	test recursive descent statement-sequence parsing
+ext/XS-APItest/t/sort.t		Test sort(xs_cmp ...)
 ext/XS-APItest/t/stmtasexpr.t	test recursive descent statement parsing
 ext/XS-APItest/t/stmtsasexpr.t	test recursive descent statement-sequence parsing
 ext/XS-APItest/t/stuff_modify_bug.t	test for eval side-effecting source string
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 1d8a551..f5aa9bd 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -3243,6 +3243,17 @@ CODE:
 OUTPUT:
     RETVAL
 
+int
+xs_cmp(int a, int b)
+CODE:
+    /* Odd sorting (odd numbers first), to make sure we are actually
+       being called */
+    RETVAL = a % 2 != b % 2
+	       ? a % 2 ? -1 : 1
+	       : a < b ? -1 : a == b ? 0 : 1;
+OUTPUT:
+    RETVAL
+
 
 MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
 
diff --git a/ext/XS-APItest/t/sort.t b/ext/XS-APItest/t/sort.t
new file mode 100644
index 0000000..c7f0c71
--- /dev/null
+++ b/ext/XS-APItest/t/sort.t
@@ -0,0 +1,10 @@
+#!perl -w
+
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+use XS::APItest;
+
+is join("", sort xs_cmp split//, '1415926535'), '1135559246',
+  'sort treats XS cmp routines as having implicit ($$)';
diff --git a/pp_sort.c b/pp_sort.c
index 2257d2f..d527d1e 100644
--- a/pp_sort.c
+++ b/pp_sort.c
@@ -1525,11 +1525,11 @@ PP(pp_sort)
 		    hasargs = TRUE;
 		}
 	    }
-	    if (!(cv && CvROOT(cv))) {
-		if (cv && CvISXSUB(cv)) {
-		    is_xsub = 1;
-		}
-		else if (gv) {
+	    if (cv && CvISXSUB(cv) && CvXSUB(cv)) {
+		is_xsub = 1;
+	    }
+	    else if (!(cv && CvROOT(cv))) {
+		if (gv) {
 		    goto autoload;
 		}
 		else if (!CvANON(cv) && (gv = CvGV(cv))) {