ExtUtils::ParseXS: Check that an XSUB with CODE&RETVAL has an OUTPUT

If an XS paragraph/function definition that has a CODE section using
RETVAL, then we need an OUTPUT section or else things will go sour.

This adds a check for that condition and produces a friendly error
message.

See CPAN RT #69536.

2 files changed, 24 insertions, 2 deletions

diff --git a/dist/ExtUtils-ParseXS/Changes b/dist/ExtUtils-ParseXS/Changes
index 4f189ca9ed..e8533baf8f 100644
--- a/dist/ExtUtils-ParseXS/Changes
+++ b/dist/ExtUtils-ParseXS/Changes
@@ -1,5 +1,8 @@
 Revision history for Perl extension ExtUtils::ParseXS.
 
+  - No detects and throws a warning if there is a CODE section using
+    RETVAL, but no OUTPUT section. [CPAN RT #69536]
+
 3.03 - Thu Aug 11 08:24:00 CET 2011
 
   - Test fix: Try all @INC-derived typemap locations. (CPAN RT #70047)
diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
index eeed387e09..e63b133f76 100644
--- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
+++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
@@ -35,7 +35,7 @@ our @EXPORT_OK = qw(
   process_file
   report_error_count
 );
-our $VERSION = '3.03';
+our $VERSION = '3.03_01';
 $VERSION = eval $VERSION if $VERSION =~ /_/;
 
 # The scalars in the line below remain as 'our' variables because pulling
@@ -597,6 +597,9 @@ EOF
         }
       }
 
+      # These are set if OUTPUT is found and/or CODE using RETVAL
+      $self->{have_OUTPUT} = $self->{have_CODE_with_RETVAL} = 0;
+
       my ($wantRETVAL);
       # do code
       if (/^\s*NOT_IMPLEMENTED_YET/) {
@@ -631,7 +634,10 @@ EOF
           print "\tPUTBACK;\n\treturn;\n";
         }
         elsif ($self->check_keyword("CODE")) {
-          $self->print_section();
+          my $consumed_code = $self->print_section();
+          if ($consumed_code =~ /\bRETVAL\b/) {
+            $self->{have_CODE_with_RETVAL} = 1;
+          }
         }
         elsif (defined($class) and $func_name eq "DESTROY") {
           print "\n\t";
@@ -672,8 +678,14 @@ EOF
       # $wantRETVAL set if 'RETVAL =' autogenerated
       ($wantRETVAL, $self->{ret_type}) = (0, 'void') if $RETVAL_no_return;
       undef %{ $self->{outargs} };
+
       $self->process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
 
+      # A CODE section with RETVAL, but no OUTPUT? FAIL!
+      if ($self->{have_CODE_with_RETVAL} and not $self->{have_OUTPUT} and $self->{ret_type} ne 'void') {
+        $self->Warn("Warning: Found a 'CODE' section which seems to be using 'RETVAL' but no 'OUTPUT' section.");
+      }
+
       generate_output( {
         type        => $self->{var_types}->{$_},
         num         => $self->{args_match}->{$_},
@@ -1000,12 +1012,17 @@ sub print_section {
   # the "do" is required for right semantics
   do { $_ = shift(@{ $self->{line} }) } while !/\S/ && @{ $self->{line} };
 
+  my $consumed_code = '';
+
   print("#line ", $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1], " \"$self->{filepathname}\"\n")
     if $self->{WantLineNumbers} && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
   for (;  defined($_) && !/^$self->{BLOCK_re}/o;  $_ = shift(@{ $self->{line} })) {
     print "$_\n";
+    $consumed_code .= "$_\n";
   }
   print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers};
+
+  return $consumed_code;
 }
 
 sub merge_section {
@@ -1137,6 +1154,8 @@ sub INPUT_handler {
 
 sub OUTPUT_handler {
   my $self = shift;
+  $self->{have_OUTPUT} = 1;
+
   $_ = shift;
   for (;  !/^$self->{BLOCK_re}/o;  $_ = shift(@{ $self->{line} })) {
     next unless /\S/;