Update ExtUtils::ParseXS to 2.19_03

2.19_03 - Sat Jun 27 22:51:18 EDT 2009

 - Released to see updated results from smoke testers

 - Fix minor doc typo pulled from blead

2.19_02 - Wed Aug  6 22:18:33 2008

 - Fix the usage reports to consistently report package name as well
   as sub name across ALIAS, INTERFACE and regular XSUBS. [Robert May]

 - Cleaned up a warning with -Wwrite-strings that gets passed into
   every parsed XS file. [Steve Peters]

 - Allow (pedantically correct) C pre-processor comments in the code
   snippets of typemap files. [Nicholas Clark]

Signed-off-by: H.Merijn Brand <h.m.brand@xs4all.nl>

5 files changed, 208 insertions, 17 deletions

diff --git a/lib/ExtUtils/ParseXS.pm b/lib/ExtUtils/ParseXS.pm
index b8ce4a0b0d..bf567aa3fb 100644
--- a/lib/ExtUtils/ParseXS.pm
+++ b/lib/ExtUtils/ParseXS.pm
@@ -18,7 +18,7 @@ my(@XSStack);	# Stack of conditionals and INCLUDEs
 my($XSS_work_idx, $cpp_next_tmp);
 
 use vars qw($VERSION);
-$VERSION = '2.19_01';
+$VERSION = '2.19_03';
 
 use vars qw(%input_expr %output_expr $ProtoUsed @InitFileCode $FH $proto_re $Overload $errors $Fallback
 	    $cplusplus $hiertype $WantPrototypes $WantVersionChk $except $WantLineNumbers
@@ -305,13 +305,56 @@ EOM
     exit 0; # Not a fatal error for the caller process
   }
 
-    print <<"EOF";
+  print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
+
+  print <<"EOF";
 #ifndef PERL_UNUSED_VAR
 #  define PERL_UNUSED_VAR(var) if (0) var = var
 #endif
 
 EOF
 
+  print <<"EOF";
+#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
+#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
+
+/* prototype to pass -Wmissing-prototypes */
+STATIC void
+S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
+
+STATIC void
+S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
+{
+    const GV *const gv = CvGV(cv);
+
+    PERL_ARGS_ASSERT_CROAK_XS_USAGE;
+
+    if (gv) {
+        const char *const gvname = GvNAME(gv);
+        const HV *const stash = GvSTASH(gv);
+        const char *const hvname = stash ? HvNAME(stash) : NULL;
+
+        if (hvname)
+            Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
+        else
+            Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
+    } else {
+        /* Pants. I don't think that it should be possible to get here. */
+        Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
+    }
+}
+#undef  PERL_ARGS_ASSERT_CROAK_XS_USAGE
+
+#ifdef PERL_IMPLICIT_CONTEXT
+#define croak_xs_usage(a,b)	S_croak_xs_usage(aTHX_ a,b)
+#else
+#define croak_xs_usage		S_croak_xs_usage
+#endif
+
+#endif
+
+EOF
+
   print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
 
   $lastline    = $_;
@@ -597,22 +640,17 @@ EOF
 #    *errbuf = '\0';
 EOF
 
-    if ($ALIAS)
-      { print Q(<<"EOF") if $cond }
-#    if ($cond)
-#       Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "$report_args");
-EOF
-    else
-      { print Q(<<"EOF") if $cond }
+    if($cond) {
+    print Q(<<"EOF");
 #    if ($cond)
-#       Perl_croak(aTHX_ "Usage: %s(%s)", "$pname", "$report_args");
+#       croak_xs_usage(cv,  "$report_args");
 EOF
-    
-     # cv doesn't seem to be used, in most cases unless we go in 
-     # the if of this else
-     print Q(<<"EOF");
+    } else {
+    # cv likely to be unused
+    print Q(<<"EOF");
 #    PERL_UNUSED_VAR(cv); /* -W */
 EOF
+    }
 
     #gcc -Wall: if an xsub has PPCODE is used
     #it is possible none of ST, XSRETURN or XSprePUSH macros are used
diff --git a/lib/ExtUtils/ParseXS/t/XSUsage.pm b/lib/ExtUtils/ParseXS/t/XSUsage.pm
new file mode 100644
index 0000000000..a3754285b9
--- /dev/null
+++ b/lib/ExtUtils/ParseXS/t/XSUsage.pm
@@ -0,0 +1,6 @@
+package XSUsage;
+
+require DynaLoader;
+@ISA = qw(Exporter DynaLoader);
+$VERSION = '0.01';
+bootstrap XSUsage $VERSION;
diff --git a/lib/ExtUtils/ParseXS/t/XSUsage.xs b/lib/ExtUtils/ParseXS/t/XSUsage.xs
new file mode 100644
index 0000000000..964acd10a2
--- /dev/null
+++ b/lib/ExtUtils/ParseXS/t/XSUsage.xs
@@ -0,0 +1,37 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+int xsusage_one()   { return 1; } 
+int xsusage_two()   { return 2; }
+int xsusage_three() { return 3; }
+int xsusage_four()  { return 4; }
+int xsusage_five()  { return 5; }
+int xsusage_six()   { return 6; }
+
+MODULE = XSUsage         PACKAGE = XSUsage	PREFIX = xsusage_
+
+PROTOTYPES: DISABLE
+
+int
+xsusage_one()
+
+int
+xsusage_two()
+    ALIAS:
+        two_x = 1
+        FOO::two = 2
+
+int
+interface_v_i()
+    INTERFACE:
+        xsusage_three
+
+int
+xsusage_four(...)
+
+int
+xsusage_five(int i, ...)
+
+int
+xsusage_six(int i = 0)
diff --git a/lib/ExtUtils/ParseXS/t/basic.t b/lib/ExtUtils/ParseXS/t/basic.t
index 9b5319e56a..f772596da8 100644
--- a/lib/ExtUtils/ParseXS/t/basic.t
+++ b/lib/ExtUtils/ParseXS/t/basic.t
@@ -64,13 +64,17 @@ if ($b->have_compiler) {
       }
     }
   }
-  1 while unlink $obj_file;
-  1 while unlink $lib_file;
+  unless ($ENV{PERL_NO_CLEANUP}) {
+    1 while unlink $obj_file;
+    1 while unlink $lib_file;
+  }
 } else {
   skip "Skipped can't find a C compiler & linker", 1 for 1..7;
 }
 
-1 while unlink $source_file;
+unless ($ENV{PERL_NO_CLEANUP}) {
+  1 while unlink $source_file;
+}
 
 #####################################################################
 
diff --git a/lib/ExtUtils/ParseXS/t/usage.t b/lib/ExtUtils/ParseXS/t/usage.t
new file mode 100644
index 0000000000..2d3bdc9746
--- /dev/null
+++ b/lib/ExtUtils/ParseXS/t/usage.t
@@ -0,0 +1,106 @@
+#!/usr/bin/perl
+
+BEGIN {
+  if ($ENV{PERL_CORE}) {
+    chdir 't' if -d 't';
+    chdir '../lib/ExtUtils/ParseXS'
+      or die "Can't chdir to lib/ExtUtils/ParseXS: $!";
+    @INC = qw(../.. ../../.. .);
+  }
+}
+use strict;
+use Test;
+BEGIN { plan tests => 24 };
+use DynaLoader;
+use ExtUtils::ParseXS qw(process_file);
+use ExtUtils::CBuilder;
+ok(1); # If we made it this far, we're loaded.
+
+chdir 't' or die "Can't chdir to t/, $!";
+
+use Carp; $SIG{__WARN__} = \&Carp::cluck;
+
+#########################
+
+my $source_file = 'XSUsage.c';
+
+# Try sending to file
+process_file(filename => 'XSUsage.xs', output => $source_file);
+ok -e $source_file, 1, "Create an output file";
+
+# TEST doesn't like extraneous output
+my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE};
+
+# Try to compile the file!  Don't get too fancy, though.
+my $b = ExtUtils::CBuilder->new(quiet => $quiet);
+if ($b->have_compiler) {
+  my $module = 'XSUsage';
+
+  my $obj_file = $b->compile( source => $source_file );
+  ok $obj_file;
+  ok -e $obj_file, 1, "Make sure $obj_file exists";
+
+  my $lib_file = $b->link( objects => $obj_file, module_name => $module );
+  ok $lib_file;
+  ok -e $lib_file, 1, "Make sure $lib_file exists";
+
+  eval {require XSUsage};
+  ok $@, '';
+
+  # The real tests here - for each way of calling the functions, call with the
+  # wrong number of arguments and check the Usage line is what we expect
+
+  eval { XSUsage::one(1) };
+  ok $@;
+  ok $@ =~ /^Usage: XSUsage::one/;
+
+  eval { XSUsage::two(1) };
+  ok $@;
+  ok $@ =~ /^Usage: XSUsage::two/;
+
+  eval { XSUsage::two_x(1) };
+  ok $@;
+  ok $@ =~ /^Usage: XSUsage::two_x/;
+
+  eval { FOO::two(1) };
+  ok $@;
+  ok $@ =~ /^Usage: FOO::two/;
+
+  eval { XSUsage::three(1) };
+  ok $@;
+  ok $@ =~ /^Usage: XSUsage::three/;
+
+  eval { XSUsage::four(1) };
+  ok !$@;
+
+  eval { XSUsage::five() };
+  ok $@;
+  ok $@ =~ /^Usage: XSUsage::five/;
+
+  eval { XSUsage::six() };
+  ok !$@;
+
+  eval { XSUsage::six(1) };
+  ok !$@;
+
+  eval { XSUsage::six(1,2) };
+  ok $@;
+  ok $@ =~ /^Usage: XSUsage::six/;
+
+  # Win32 needs to close the DLL before it can unlink it, but unfortunately
+  # dl_unload_file was missing on Win32 prior to perl change #24679!
+  if ($^O eq 'MSWin32' and defined &DynaLoader::dl_unload_file) {
+    for (my $i = 0; $i < @DynaLoader::dl_modules; $i++) {
+      if ($DynaLoader::dl_modules[$i] eq $module) {
+        DynaLoader::dl_unload_file($DynaLoader::dl_librefs[$i]);
+        last;
+      }
+    }
+  }
+  1 while unlink $obj_file;
+  1 while unlink $lib_file;
+} else {
+  skip "Skipped can't find a C compiler & linker", 1 for 3 .. 24;
+}
+
+1 while unlink $source_file;