Author: kwilliams
Date: Wed Jul 30 20:58:42 2008
New Revision: 11616
Added:
ExtUtils-ParseXS/trunk/t/XSUsage.pm
ExtUtils-ParseXS/trunk/t/XSUsage.xs
ExtUtils-ParseXS/trunk/t/usage.t
Modified:
ExtUtils-ParseXS/trunk/lib/ExtUtils/ParseXS.pm
Log:
Applied Robert May's patch for better error reporting in INTERFACE and/or ALIAS
situations
Modified: ExtUtils-ParseXS/trunk/lib/ExtUtils/ParseXS.pm
==============================================================================
--- ExtUtils-ParseXS/trunk/lib/ExtUtils/ParseXS.pm (original)
+++ ExtUtils-ParseXS/trunk/lib/ExtUtils/ParseXS.pm Wed Jul 30 20:58:42 2008
@@ -18,7 +18,7 @@
my($XSS_work_idx, $cpp_next_tmp);
use vars qw($VERSION);
-$VERSION = '2.19';
+$VERSION = '2.19_02';
use vars qw(%input_expr %output_expr $ProtoUsed @InitFileCode $FH $proto_re
$Overload $errors $Fallback
$cplusplus $hiertype $WantPrototypes $WantVersionChk $except
$WantLineNumbers
@@ -305,13 +305,55 @@
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)
+
+/* Copied from universal.c */
+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_get(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,20 +639,13 @@
# *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 }
+ print Q(<<"EOF") if $cond;
# 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");
+ # cv doesn't seem to be used, unless $cond, above
+ print Q(<<"EOF") unless $cond;
# PERL_UNUSED_VAR(cv); /* -W */
EOF
Added: ExtUtils-ParseXS/trunk/t/XSUsage.pm
==============================================================================
--- (empty file)
+++ ExtUtils-ParseXS/trunk/t/XSUsage.pm Wed Jul 30 20:58:42 2008
@@ -0,0 +1,6 @@
+package XSUsage;
+
+require DynaLoader;
[EMAIL PROTECTED] = qw(Exporter DynaLoader);
+$VERSION = '0.01';
+bootstrap XSUsage $VERSION;
Added: ExtUtils-ParseXS/trunk/t/XSUsage.xs
==============================================================================
--- (empty file)
+++ ExtUtils-ParseXS/trunk/t/XSUsage.xs Wed Jul 30 20:58:42 2008
@@ -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)
Added: ExtUtils-ParseXS/trunk/t/usage.t
==============================================================================
--- (empty file)
+++ ExtUtils-ParseXS/trunk/t/usage.t Wed Jul 30 20:58:42 2008
@@ -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;
