Prevent segfault when qsort etc called with a scalar argument

If a user mistakenly passed a perl scalar argument to qsort and its ilk, the SV would be mistaken for a piddle and passed to the underlying generic_qsort etc routines. Not surprisingly, those routine's array index tricks would cause a segfault. This commit causes qsort, qsorti, qsortvec, and qsortveci to barf if an argument is passed with incorrect dimensions. Some care is taken to allow trivial sorts. 2 tests for each routine have been added, and some existing tests labeled.
PDLPorters · Jun 27, 2016 · 0522ad9 · 0522ad9
1 parent 418b592
commit 0522ad9
Show file tree

Hide file tree

Showing 2 changed files with 44 additions and 8 deletions.
diff --git a/Basic/Ufunc/ufunc.pd b/Basic/Ufunc/ufunc.pd
@@ -1083,13 +1083,19 @@ pp_def(
     'PDL_Indx nn;
      loop(n) %{ $b() = $a(); %}
      nn = $COMP(__n_size)-1;
+     if ($PDL(a)->dims[0] != $PDL(b)->dims[0] && $PDL(a)->dims[0]!=0 && $PDL(b)->dims[0]!=1){
+        pdl_barf("You likely passed a scalar argument to qsort, when you should have passed a piddle (or nothing at all)");
+     }
     ' . generic_qsort('b'),
     BadCode =>
     'register PDL_Indx nn = 0, nb = $SIZE(n) - 1;
      loop(n) %{ 
         if ( $ISGOOD(a()) ) { $b(n=>nn) = $a(); nn++; }
         else                { $SETBAD(b(n=>nb)); nb--; }
      %}
+     if ($PDL(a)->dims[0] != $PDL(b)->dims[0] && $PDL(b)->dims[0]!=0 && $PDL(b)->dims[0]!=1){
+        pdl_barf("You likely passed a scalar argument to qsort, when you should have passed a piddle (or nothing at all)");
+     }
      if ( nn != 0 ) {
         nn -= 1;
      ' . generic_qsort('b') . ' }',
@@ -1132,6 +1138,9 @@ pp_def(
         loop(n) %{ 
            $indx() = n; 
         %}
+        if ($PDL(a)->dims[0] != $PDL(indx)->dims[0] && $PDL(a)->dims[0]!=0 && $PDL(indx)->dims[0]!=1){
+           pdl_barf("You likely passed a scalar argument to qsorti, when you should have passed a piddle (or nothing at all)");
+        }
        ' . generic_qsort_ind(),
        BadCode =>
        'register PDL_Indx nn = 0, nb = $SIZE(n) - 1;
@@ -1140,6 +1149,9 @@ pp_def(
            if ( $ISGOOD(a()) ) { $indx(n=>nn) = n; nn++; } /* play safe since nn used more than once */ 
            else                { $indx(n=>nb) = n; nb--; }
         %}
+         if ($PDL(a)->dims[0] != $PDL(indx)->dims[0] && $PDL(a)->dims[0]!=0 && $PDL(indx)->dims[0]!=1){
+            pdl_barf("You likely passed a scalar argument to qsorti, when you should have passed a piddle (or nothing at all)");
+        }
         if ( nn != 0 ) {
            nn -= 1;
         ' . generic_qsort_ind() . ' }',
@@ -1181,6 +1193,9 @@ pp_def(
      loop(n,m) %{ $b() = $a(); %}
      nn = ($COMP(__m_size))-1;
      nd = $COMP(__n_size);
+     if (($PDL(a)->dims[0] != $PDL(b)->dims[0] || $PDL(a)->dims[1] != $PDL(b)->dims[1]) && $PDL(a)->dims[1] !=0 && $PDL(b)->dims[1] != 1){
+        pdl_barf("You likely passed a scalar argument to qsortvec, when you should have passed a piddle (or nothing at all)");
+     }
     ' . generic_qsortvec('b','nd'),
     Doc => '
 =for ref
@@ -1210,7 +1225,7 @@ the 1st dimension is list order.  Higher dimensions are threaded over.
 '
 Vectors with bad components should be moved to the end of the array:
 ',
-    ); # pp_def qsort
+    ); # pp_def qsortvec
 
 sub generic_qsortvec_ind {
     my $pdl = shift;
@@ -1230,6 +1245,9 @@ pp_def(
         $indx()=m;
      %}
      nd = $COMP(__n_size);
+     if ($PDL(a)->ndims >1 && $PDL(a)->dims[1] != $PDL(indx)->dims[0] && $PDL(a)->dims[1]!=0 && $PDL(indx)->dims[0]!=1){
+        pdl_barf("You likely passed a scalar argument to qsortveci, when you should have passed a piddle (or nothing at all)");
+     }
     ' . generic_qsortvec_ind('a','nd'),
     Doc => '
 =for ref

diff --git a/t/ufunc.t b/t/ufunc.t
@@ -3,7 +3,7 @@
 # Test some Basic/Ufunc routines
 
 use strict;
-use Test::More tests => 35;
+use Test::More tests => 43;
 
 BEGIN {
     # if we've got this far in the tests then 
@@ -53,25 +53,43 @@ ok( ( eval { pdl([])->qsorti }, $@ eq '' ), "qsorti coredump,[SF bug 2110074]");
 
 # Test inplace sorting
 $d->inplace->qsort;
-ok(all($d == $d_sort));
+ok(all($d == $d_sort), "inplace sorting");
 
 # Test inplace sorting with bad values
 $d->setbadat(3);
 $d_sort = $d->qsort;
 $d->inplace->qsort;
-ok(all($d == $d_sort));
+ok(all($d == $d_sort), "inplace sorting with bad values");
 
 # Test inplace lexicographical sorting
 $e->inplace->qsortvec;
-ok(all($e == $e_sort));
+ok(all($e == $e_sort), "inplace lexicographical sorting");
 
 # Test inplace lexicographical sorting with bad values
 $e->setbadat(1,3);
 $e_sort = $e->qsortvec;
 $e->inplace->qsortvec;
-ok(all($e == $e_sort));
-
-# test for sf.net but report 3234141 "max() fails on nan"
+ok(all($e == $e_sort), "inplace lexicographical sorting with bad values");
+
+# Test sf.net bug 379 "Passing qsort an extra argument causes a segfault"
+# (also qsorti, qsortvec, qsortveci)
+eval { random(15)->qsort(5); };
+ok($@ ne '', "qsort extra argument");
+eval { random(15)->qsorti(5); };
+ok($@ ne '', "qsorti extra argument");
+eval {random(10,4)->qsortvec(5); };
+ok($@ ne '', "qsortvec extra argument");
+eval {random(10,4)->qsortveci(2); };
+ok(@$ ne '', "qsortveci extra argument");
+#but the dimension size checks for those cases shouldn't derail trivial qsorts:
+is(pdl(5)->qsort,pdl(5),'trivial qsort');
+is(pdl(8)->qsorti,pdl(0),'trivial qsorti');
+ok(all(pdl(42,41)->qsortvec == pdl(42,41)->dummy(1)),'trivial qsortvec');
+is(pdl(53,35)->qsortveci,pdl(0),'trivial qsortveci');
+
+
+
+# test for sf.net bug report 3234141 "max() fails on nan"
 #   NaN values are handled inconsistently by min, minimum, max, maximum...
 #
 local $TODO = "fixing max/min NaN handling";