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

[perl5.git] / dist / ExtUtils-ParseXS / lib / ExtUtils / ParseXS.pm

diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
index 1b46bd4..e63b133 100644 (file)
--- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
+++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
@@ -1,7 +1,7 @@
 package ExtUtils::ParseXS;
 use strict;
 
-use 5.006;  # We use /??{}/ in regexes
+use 5.008001;  # We use /??{}/ in regexes
 use Cwd;
 use Config;
 use Exporter;
@@ -24,7 +24,7 @@ use ExtUtils::ParseXS::Utilities qw(
   analyze_preprocessor_statements
   set_cond
   Warn
-  CurrentLineNumber
+  current_line_number
   blurt
   death
   check_conditional_preprocessor_statements
@@ -35,7 +35,7 @@ our @EXPORT_OK = qw(
   process_file
   report_error_count
 );
-our $VERSION = '3';
+our $VERSION = '3.03_01';
 $VERSION = eval $VERSION if $VERSION =~ /_/;
 
 # The scalars in the line below remain as 'our' variables because pulling
@@ -84,9 +84,9 @@ sub process_file {
   }
   @{ $self->{XSStack} } = ({type => 'none'});
   $self->{InitFileCode} = [ @ExtUtils::ParseXS::Constants::InitFileCode ];
-  $self->{Overload}     = $ExtUtils::ParseXS::Constants::Overload;
+  $self->{Overload}     = 0;
   $self->{errors}       = 0;
-  $self->{Fallback}     = $ExtUtils::ParseXS::Constants::Fallback;
+  $self->{Fallback}     = '&PL_sv_undef';
 
   # Most of the 1500 lines below uses these globals.  We'll have to
   # clean this up sometime, probably.  For now, we just pull them out
@@ -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/;
@@ -1494,7 +1513,9 @@ sub INCLUDE_handler {
 EOF
 
   $self->{filename} = $_;
-  $self->{filepathname} = File::Spec->catfile($self->{dir}, $self->{filename});
+  $self->{filepathname} = ( $^O =~ /^mswin/i )
+                          ? qq($self->{dir}/$self->{filename}) # See CPAN RT #61908: gcc doesn't like backslashes on win32?
+                          : File::Spec->catfile($self->{dir}, $self->{filename});
 
   # Prime the pump by reading the first
   # non-blank line
@@ -1553,7 +1574,8 @@ EOF
 
   $self->{filename} = $_;
   $self->{filepathname} = $self->{filename};
-  $self->{filepathname} =~ s/\"/\\"/g;
+  #$self->{filepathname} =~ s/\"/\\"/g; # Fails? See CPAN RT #53938: MinGW Broken after 2.21
+  $self->{filepathname} =~ s/\\/\\\\/g; # Works according to reporter of #53938
 
   # Prime the pump by reading the first
   # non-blank line
@@ -1668,7 +1690,7 @@ sub fetch_para {
       my $tmapcode = join "", @tmaplines;
       my $tmap = ExtUtils::Typemaps->new(
         string => $tmapcode,
-        lineno_offset => $self->CurrentLineNumber()+1,
+        lineno_offset => $self->current_line_number()+1,
         fake_filename => $self->{filename},
       );
       $self->{typemap}->merge(typemap => $tmap, replace => 1);