Merge pull request #454 from PDLPorters/fix-empty-vsearch

vsearch: fix segv if vsearch $x arg is empty; add support for bad vaues in $vals argument
PDLPorters · Sep 21, 2023 · d144131 · d144131
2 parents 457ff25 + a49af89
commit d144131
Show file tree

Hide file tree

Showing 2 changed files with 62 additions and 12 deletions.
diff --git a/Basic/Primitive/primitive.pd b/Basic/Primitive/primitive.pd
@@ -2913,17 +2913,39 @@ for my $func ( [
 
 
     my $code = undent q[
-                   PDL_Indx n1 = $SIZE(n)-1;
-                   PDL_Indx low = %LOW%;
-                   PDL_Indx high = %HIGH%;
-                   PDL_Indx mid;
+                 if ( $SIZE(n) == 0 ){
+                    broadcastloop %{
+                      loop(n) %{
+                        $SETBAD(idx());
+                      %}
+                    %}
+                 }
+                 else {
+                   broadcastloop %{
 
-		   $GENERIC() value = $vals();
+                     loop(n) %{
 
-                   /* determine sort order of data */
-                   int up = %UP%;
-                   %CODE%
-                   ----
+                        if ( $ISGOOD(vals()) ) {
+                          PDL_Indx n1 = $SIZE(n)-1;
+                          PDL_Indx low = %LOW%;
+                          PDL_Indx high = %HIGH%;
+                          PDL_Indx mid;
+
+                          $GENERIC() value = $vals();
+
+                          /* determine sort order of data */
+                          int up = %UP%;
+                          %CODE%
+                        }
+
+                        else {
+                          $SETBAD(idx());
+                        }
+                     %}
+
+                   %}
+                 }
+                 ----
                ];
 
     my $doc = undent q[
@@ -2936,7 +2958,8 @@ for my $func ( [
 		     $idx = %FUNC%($vals, $x);
 
 		   C<$x> must be sorted, but may be in decreasing or increasing
-		   order.
+		   order.  if C<$x> is empty, then all values in C<$idx> will be
+                   set to the bad value.
 
                    %PRE%
 		   %BODY%
@@ -2952,8 +2975,8 @@ for my $func ( [
 
     pp_def(
         $func,
-        HandleBad    => 0,
-        BadDoc       => 'needs major (?) work to handles bad values',
+        HandleBad    => 1,
+        BadDoc       => 'bad values in vals() result in bad values in idx()',
         Pars         => 'vals(); x(n); indx [o]idx()',
         GenericTypes => $F,    # too restrictive ?
         Code         => $code,

diff --git a/t/primitive/vsearch.t b/t/primitive/vsearch.t
@@ -3,6 +3,7 @@
 use strict;
 use warnings;
 use Test2::V0 '!float';
+use Test2::Util;
 
 use PDL::LiteF;
 use Test::Lib;
@@ -375,6 +376,14 @@ for my $mode ( sort keys %search ) {
                     $so->{equal} ),
                   'equal elements';
 
+                my $badmask = $so->{x}->random < 0.25;
+                my $badx = $so->{x}->setbadif( $badmask );
+                my $bad_eq = $so->{equal}->setbadif( $badmask );
+
+                ok tapprox( vsearch( $badx, $so->{x}, { mode => $mode } ),
+                    $bad_eq ),
+                  'equal elements w/ bad vals';
+
                 ok tapprox(
                     vsearch( $so->{x} - 5, $so->{x}, { mode => $mode } ),
                     $so->{nequal_m} ),
@@ -446,4 +455,22 @@ for my $mode ( sort keys %search ) {
     ok tapprox( $indx0, $indx1 ), 'explicit ndarray == implicit ndarray';
 }
 
+subtest regressions => sub {
+
+    subtest '$xs->is_empty' => sub {
+
+        skip 'check for regression requires fork' unless Test2::Util::CAN_FORK;
+        require Test2::AsyncSubtest;
+
+        my $ast = Test2::AsyncSubtest->new( name => 'vsearch' );
+        $ast->run_fork(
+            sub {
+                ok lives { pdl( [0] )->vsearch_bin_inclusive( pdl( [] ) ) }
+            }
+        );
+        $ast->finish;
+
+    };
+
+};
 done_testing;