Now that ExtUtils::ParseXS requires 5.006, we can replace the foreach

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

diff --git a/lib/ExtUtils/ParseXS.pm b/lib/ExtUtils/ParseXS.pm
index adad27f..4c519fc 100644 (file)
--- a/lib/ExtUtils/ParseXS.pm
+++ b/lib/ExtUtils/ParseXS.pm
@@ -5,6 +5,7 @@ use Cwd;
 use Config;
 use File::Basename;
 use File::Spec;
+use Symbol;
 
 require Exporter;
 
@@ -17,7 +18,7 @@ my(@XSStack); # Stack of conditionals and INCLUDEs
 my($XSS_work_idx, $cpp_next_tmp);
 
 use vars qw($VERSION);
-$VERSION = '2.12';
+$VERSION = '2.18_01';
 
 use vars qw(%input_expr %output_expr $ProtoUsed @InitFileCode $FH $proto_re $Overload $errors $Fallback
            $cplusplus $hiertype $WantPrototypes $WantVersionChk $except $WantLineNumbers
@@ -71,7 +72,7 @@ sub process_file {
   @XSStack = ({type => 'none'});
   ($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
   @InitFileCode = ();
-  $FH = 'File0000' ;
+  $FH = Symbol::gensym();
   $proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ;
   $Overload = 0;
   $errors = 0;
@@ -192,8 +193,8 @@ sub process_file {
     close(TYPEMAP);
   }
 
-  foreach my $key (keys %input_expr) {
-    $input_expr{$key} =~ s/;*\s+\z//;
+  foreach my $value (values %input_expr) {
+    $value =~ s/;*\s+\z//;
   }
 
   my ($cast, $size);
@@ -202,7 +203,7 @@ sub process_file {
   $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)
 
   foreach my $key (keys %output_expr) {
-    use re 'eval';
+    BEGIN { $^H |= 0x00200000 }; # Equivalent to: use re 'eval', but hardcoded so we can compile re.xs
 
     my ($t, $with_size, $arg, $sarg) =
       ($output_expr{$key} =~
@@ -359,7 +360,7 @@ EOF
           ." followed by a statement on column one?)")
       if $line[0] =~ /^\s/;
     
-    my ($class, $externC, $static, $elipsis, $wantRETVAL, $RETVAL_no_return);
+    my ($class, $externC, $static, $ellipsis, $wantRETVAL, $RETVAL_no_return);
     my (@fake_INPUT_pre);      # For length(s) generated variables
     my (@fake_INPUT);
     
@@ -455,7 +456,7 @@ EOF
                                             \b ( \w+ | length\( \s*\w+\s* \) )
                                             \s* $ /x);
          next unless defined($pre) && length($pre);
-         my $out_type;
+         my $out_type = '';
          my $inout_var;
          if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) {
            my $type = $1;
@@ -512,7 +513,7 @@ EOF
     my $report_args = '';
     foreach my $i (0 .. $#args) {
       if ($args[$i] =~ s/\.\.\.//) {
-       $elipsis = 1;
+       $ellipsis = 1;
        if ($args[$i] eq '' && $i == $#args) {
          $report_args .= ", ...";
          pop(@args);
@@ -564,7 +565,11 @@ EOF
 #XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
 #XS(XS_${Full_func_name})
 #[[
+##ifdef dVAR
+#    dVAR; dXSARGS;
+##else
 #    dXSARGS;
+##endif
 EOF
     print Q(<<"EOF") if $ALIAS ;
 #    dXSI32;
@@ -572,7 +577,7 @@ EOF
     print Q(<<"EOF") if $INTERFACE ;
 #    dXSFUNCTION($ret_type);
 EOF
-    if ($elipsis) {
+    if ($ellipsis) {
       $cond = ($min_args ? qq(items < $min_args) : 0);
     } elsif ($min_args == $num_args) {
       $cond = qq(items != $min_args);
@@ -588,12 +593,12 @@ EOF
     if ($ALIAS)
       { print Q(<<"EOF") if $cond }
 #    if ($cond)
-#       Perl_croak(aTHX_ "Usage: %s($report_args)", GvNAME(CvGV(cv)));
+#       Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "$report_args");
 EOF
     else
       { print Q(<<"EOF") if $cond }
 #    if ($cond)
-#      Perl_croak(aTHX_ "Usage: $pname($report_args)");
+#       Perl_croak(aTHX_ "Usage: %s(%s)", "$pname", "$report_args");
 EOF
     
      # cv doesn't seem to be used, in most cases unless we go in 
@@ -837,7 +842,7 @@ EOF
          $proto_arg[$min_args] .= ";" ;
        }
        push @proto_arg, "$s\@"
-         if $elipsis ;
+         if $ellipsis ;
        
        $proto = join ("", grep defined, @proto_arg);
       }
@@ -918,7 +923,11 @@ EOF
 
   print Q(<<"EOF");
 #[[
+##ifdef dVAR
+#    dVAR; dXSARGS;
+##else
 #    dXSARGS;
+##endif
 EOF
 
   #-Wall: if there is no $Full_func_name there are no xsubs in this .xs
@@ -971,6 +980,13 @@ EOF
     print "\n    /* End of Initialisation Section */\n\n" ;
   }
 
+  if ($] >= 5.009) {
+    print <<'EOF';
+    if (PL_unitcheckav)
+         call_list(PL_scopestack_ix, PL_unitcheckav);
+EOF
+  }
+
   print Q(<<"EOF");
 #    XSRETURN_YES;
 #]]
@@ -983,6 +999,7 @@ EOF
   chdir($orig_cwd);
   select($orig_fh);
   untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
+  close $FH;
 
   return 1;
 }
@@ -1211,7 +1228,9 @@ sub INTERFACE_handler() {
   TrimWhitespace($in);
 
   foreach (split /[\s,]+/, $in) {
-    $Interfaces{$_} = $_;
+    my $name = $_;
+    $name =~ s/^$Prefix//;
+    $Interfaces{$name} = $_;
   }
   print Q(<<"EOF");
 #      XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
@@ -1436,10 +1455,11 @@ sub INCLUDE_handler ()
                    Line            => \@line,
                    LineNo          => \@line_no,
                    Filename        => $filename,
+                   Filepathname    => $filepathname,
                    Handle          => $FH,
                   }) ;
 
-    ++ $FH ;
+    $FH = Symbol::gensym();
 
     # open the new file
     open ($FH, "$_") or death("Cannot open '$_': $!") ;
@@ -1450,7 +1470,7 @@ sub INCLUDE_handler ()
 #
 EOF
 
-    $filename = $_ ;
+    $filepathname = $filename = $_ ;
 
     # Prime the pump by reading the first
     # non-blank line
@@ -1479,7 +1499,11 @@ sub PopFile()
     close $FH ;
 
     $FH         = $data->{Handle} ;
+    # $filename is the leafname, which for some reason isused for diagnostic
+    # messages, whereas $filepathname is the full pathname, and is used for
+    # #line directives.
     $filename   = $data->{Filename} ;
+    $filepathname = $data->{Filepathname} ;
     $lastline   = $data->{LastLine} ;
     $lastline_no = $data->{LastLineNo} ;
     @line       = @{ $data->{Line} } ;