ParseXS - make testing easier

Use warn instead of print STDERR, and provide a way to make
errors trigger a die instead of an exit(1).

Currently the module code is written as though the only way
it will be used is via the xsubpp script, so the library does
annoying things like calling exit() instead of die() to signal
an exception. It also uses print STDERR instead of warn,
which means the test code can't just use a $SIG{__WARN__} hook
to see its warnings, and instead has to include PrimitiveCapture
in the t directory. These two things combine annoyingly in our
test code such that when you break the module you can see tests
exiting early, but with no useful diagnostics as to why.

This patch reworks this to use "warn" instead of print STDERR,
and to provide a way to enable the use of "die" instead of exit.
Thus making debugging failing tests far easier.

6 files changed, 59 insertions, 10 deletions

diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
index ab70cc7f21..cffa89a114 100644
--- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
+++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
@@ -48,7 +48,7 @@ our @EXPORT_OK = qw(
 
 ##############################
 # A number of "constants"
-
+our $DIE_ON_ERROR;
 our ($C_group_rex, $C_arg);
 # Group in C (no support for comments or literals)
 $C_group_rex = qr/ [({\[]
@@ -104,6 +104,7 @@ sub process_file {
     typemap         => [],
     versioncheck    => 1,
     FH              => Symbol::gensym(),
+    die_on_error    => $DIE_ON_ERROR, # if true we die() and not exit() after errors
     %options,
   );
   $args{except} = $args{except} ? ' TRY' : '';
@@ -134,6 +135,8 @@ sub process_file {
   $self->{WantLineNumbers} = $args{linenumbers};
   $self->{IncludedFiles} = {};
 
+  $self->{die_on_error} = $args{die_on_error};
+
   die "Missing required parameter 'filename'" unless $args{filename};
   $self->{filepathname} = $args{filename};
   ($self->{dir}, $self->{filename}) =
diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pod b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pod
index 80bf13fd07..093a3175fc 100644
--- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pod
+++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pod
@@ -19,6 +19,7 @@ ExtUtils::ParseXS - converts Perl XS code into C code
                       linenumbers => 1,
                       optimize => 1,
                       prototypes => 1,
+                      die_on_error => 0,
                     );
 
   # Legacy non-OO interface using a singleton:
@@ -119,6 +120,15 @@ Default is true.
 
 I<Maintainer note:> I have no clue what this does.  Strips function prefixes?
 
+=item B<die_on_error>
+
+Normally ExtUtils::ParseXS will terminate the program with an C<exit(1)> after
+printing the details of the exception to STDERR via (warn). This can be awkward
+when it is used programmatically and not via xsubpp, so this option can be used
+to cause it to die instead by providing a true value. When not provided this
+defaults to the value of C<$ExtUtils::ParseXS::DIE_ON_ERROR> which in turn
+defaults to false.
+
 =back
 
 =item $pxs->report_error_count()
diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm
index 438b94b764..ab10b0e53b 100644
--- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm
+++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm
@@ -698,13 +698,42 @@ None.
 =cut
 
 sub WarnHint {
+  warn _MsgHint(@_);
+}
+
+=head2 C<_MsgHint()>
+
+=over 4
+
+=item * Purpose
+
+Constructs an exception message with line number details. The last argument is
+assumed to be a hint string.
+
+=item * Arguments
+
+List of strings to warn, followed by one argument representing a hint.
+If that argument is defined then it will be split on newlines and concatenated
+line by line (parenthesized) after the main message.
+
+=item * Return Value
+
+The constructed string.
+
+=back
+
+=cut
+
+
+sub _MsgHint {
   my $self = shift;
   my $hint = pop;
   my $warn_line_number = $self->current_line_number();
-  print STDERR join("",@_), " in $self->{filename}, line $warn_line_number\n";
+  my $ret = join("",@_) . " in $self->{filename}, line $warn_line_number\n";
   if ($hint) {
-    print STDERR "    ($_)\n" for split /\n/, $hint;
+    $ret .= "    ($_)\n" for split /\n/, $hint;
   }
+  return $ret;
 }
 
 =head2 C<blurt()>
@@ -742,8 +771,13 @@ sub blurt {
 =cut
 
 sub death {
-  my $self = shift;
-  $self->Warn(@_);
+  my $self = (@_);
+  my $message = _MsgHint(@_,"");
+  if ($self->{die_on_error}) {
+    die $message;
+  } else {
+    warn $message;
+  }
   exit 1;
 }
 
diff --git a/dist/ExtUtils-ParseXS/t/001-basic.t b/dist/ExtUtils-ParseXS/t/001-basic.t
index 990531029c..bbeb917ca5 100644
--- a/dist/ExtUtils-ParseXS/t/001-basic.t
+++ b/dist/ExtUtils-ParseXS/t/001-basic.t
@@ -15,7 +15,9 @@ require_ok( 'ExtUtils::ParseXS' );
 chdir('t') if -d 't';
 push @INC, '.';
 
-use Carp; $SIG{__WARN__} = \&Carp::cluck;
+$ExtUtils::ParseXS::DIE_ON_ERROR = 1;
+
+use Carp; #$SIG{__WARN__} = \&Carp::cluck;
 
 # The linker on some platforms doesn't like loading libraries using relative
 # paths. Android won't find relative paths, and system perl on macOS will
@@ -225,12 +227,12 @@ like $stderr, '/No INPUT definition/', "Exercise typemap error";
 { # tight cpp directives
   my $pxs = ExtUtils::ParseXS->new;
   tie *FH, 'Foo';
-  my $stderr = PrimitiveCapture::capture_stderr(sub {
+  my $stderr = PrimitiveCapture::capture_stderr(sub { eval {
     $pxs->process_file(
       filename => 'XSTightDirectives.xs',
       output => \*FH,
       prototypes => 1);
-  });
+  } or warn $@ });
   my $content = tied(*FH)->{buf};
   my $count = 0;
   $count++ while $content=~/^XS_EUPXS\(XS_My_do\)\n\{/mg;
diff --git a/dist/ExtUtils-ParseXS/t/002-more.t b/dist/ExtUtils-ParseXS/t/002-more.t
index ee3bf9b802..f118f2c9c1 100644
--- a/dist/ExtUtils-ParseXS/t/002-more.t
+++ b/dist/ExtUtils-ParseXS/t/002-more.t
@@ -19,7 +19,7 @@ ExtUtils::ParseXS->import('process_file');
 chdir 't' if -d 't';
 push @INC, '.';
 
-use Carp; $SIG{__WARN__} = \&Carp::cluck;
+use Carp; #$SIG{__WARN__} = \&Carp::cluck;
 
 # See the comments about this in 001-basics.t
 @INC = map { File::Spec->rel2abs($_) } @INC;
diff --git a/dist/ExtUtils-ParseXS/t/003-usage.t b/dist/ExtUtils-ParseXS/t/003-usage.t
index 52b99035ee..f33e3e0d9c 100644
--- a/dist/ExtUtils-ParseXS/t/003-usage.t
+++ b/dist/ExtUtils-ParseXS/t/003-usage.t
@@ -20,7 +20,7 @@ require_ok( 'ExtUtils::ParseXS' );
 chdir('t') if -d 't';
 push @INC, '.';
 
-use Carp; $SIG{__WARN__} = \&Carp::cluck;
+use Carp; #$SIG{__WARN__} = \&Carp::cluck;
 
 # See the comments about this in 001-basics.t
 @INC = map { File::Spec->rel2abs($_) } @INC;