From: David Golden Date: Mon, 5 Oct 2009 15:31:12 +0000 (-0400) Subject: Update ExtUtils::ParseXS to 2.21 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=28892255e8c33d179344895bc2017411c3e6eb11;p=p5sagit%2Fp5-mst-13.2.git Update ExtUtils::ParseXS to 2.21 2.21 - Mon Oct 5 11:17:53 EDT 2009 Bug fixes: - Adds full path in INCLUDE #line directives (RT#50198) [patch by "spb"] Other: - Updated copyright and maintainer list 2.20_07 - Sat Oct 3 11:26:55 EDT 2009 Bug fixes: - Use "char* file" for perl < 5.9, not "char[] file"; fixes mod_perl breakage due to prior attempts to fix RT#48104 [David Golden] 2.20_06 - Fri Oct 2 23:45:45 EDT 2009 Bug fixes: - Added t/typemap to fix broken test on perl 5.6.2 [David Golden] - More prototype fixes for older perls [Goro Fuji] - Avoid "const char *" in test files as it breaks on 5.6.2 [Goro Fuji] Other: - Merged changes from 2.2004 maintenance branch (see 2.200401 to 2.200403) [David Golden] 2.20_05 - Sat Aug 22 21:46:56 EDT 2009 Bug fixes: - Fix prototype related bugs [Goro Fuji] - Fix the SCOPE keyword [Goro Fuji] --- diff --git a/MANIFEST b/MANIFEST index fb684bf..4ab2ea9 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1035,7 +1035,11 @@ cpan/ExtUtils-ParseXS/Changes ExtUtils::ParseXS change log cpan/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm converts Perl XS code into C code cpan/ExtUtils-ParseXS/lib/ExtUtils/xsubpp External subroutine preprocessor cpan/ExtUtils-ParseXS/t/basic.t See if ExtUtils::ParseXS works +cpan/ExtUtils-ParseXS/t/more.t Extended ExtUtils::ParseXS testing +cpan/ExtUtils-ParseXS/t/typemap Standard typemap for controlled testing cpan/ExtUtils-ParseXS/t/usage.t ExtUtils::ParseXS tests +cpan/ExtUtils-ParseXS/t/XSInclude.xsh Test file for ExtUtils::ParseXS tests +cpan/ExtUtils-ParseXS/t/XSMore.xs Test file for ExtUtils::ParseXS tests cpan/ExtUtils-ParseXS/t/XSTest.pm Test file for ExtUtils::ParseXS tests cpan/ExtUtils-ParseXS/t/XSTest.xs Test file for ExtUtils::ParseXS tests cpan/ExtUtils-ParseXS/t/XSUsage.pm ExtUtils::ParseXS tests diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 37c04e3..8dc844d 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -626,7 +626,7 @@ use File::Glob qw(:case); 'ExtUtils::ParseXS' => { 'MAINTAINER' => 'kwilliams', - 'DISTRIBUTION' => 'DAGOLDEN/ExtUtils-ParseXS-2.200403.tar.gz', + 'DISTRIBUTION' => 'DAGOLDEN/ExtUtils-ParseXS-2.21.tar.gz', 'FILES' => q[cpan/ExtUtils-ParseXS], 'CPAN' => 1, 'UPSTREAM' => 'cpan', diff --git a/cpan/ExtUtils-ParseXS/Changes b/cpan/ExtUtils-ParseXS/Changes index 634d8d9..d11c870 100644 --- a/cpan/ExtUtils-ParseXS/Changes +++ b/cpan/ExtUtils-ParseXS/Changes @@ -1,5 +1,36 @@ Revision history for Perl extension ExtUtils::ParseXS. +2.21 - Mon Oct 5 11:17:53 EDT 2009 + + Bug fixes: + - Adds full path in INCLUDE #line directives (RT#50198) [patch by "spb"] + + Other: + - Updated copyright and maintainer list + +2.20_07 - Sat Oct 3 11:26:55 EDT 2009 + + Bug fixes: + - Use "char* file" for perl < 5.9, not "char[] file"; fixes mod_perl + breakage due to prior attempts to fix RT#48104 [David Golden] + +2.20_06 - Fri Oct 2 23:45:45 EDT 2009 + + Bug fixes: + - Added t/typemap to fix broken test on perl 5.6.2 [David Golden] + - More prototype fixes for older perls [Goro Fuji] + - Avoid "const char *" in test files as it breaks on 5.6.2 [Goro Fuji] + + Other: + - Merged changes from 2.2004 maintenance branch (see 2.200401 to 2.200403) + [David Golden] + +2.20_05 - Sat Aug 22 21:46:56 EDT 2009 + + Bug fixes: + - Fix prototype related bugs [Goro Fuji] + - Fix the SCOPE keyword [Goro Fuji] + 2.200403 - Fri Oct 2 02:01:58 EDT 2009 Other: @@ -18,6 +49,7 @@ Revision history for Perl extension ExtUtils::ParseXS. - No changes from 2.20_04. + 2.20_04 - Mon Aug 10 11:18:47 EDT 2009 Bug fixes: @@ -30,8 +62,8 @@ Revision history for Perl extension ExtUtils::ParseXS. 2.20_03 - Thu Jul 23 23:14:50 EDT 2009 Bug fixes: - - Fixed "const char *" errors for 5.8.8 (and older) (RT#48104) - [Vincent Pit] + - Fixed "const char *" errors for 5.8.8 (and older) (RT#48104) + [Vincent Pit] - Added newline before a preprocessor directive (RT#30673) [patch by hjp] diff --git a/cpan/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm b/cpan/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm index 4835d53..05c3e69 100644 --- a/cpan/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm +++ b/cpan/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm @@ -18,7 +18,8 @@ my(@XSStack); # Stack of conditionals and INCLUDEs my($XSS_work_idx, $cpp_next_tmp); use vars qw($VERSION); -$VERSION = '2.200403'; +$VERSION = '2.21'; +$VERSION = eval $VERSION if $VERSION =~ /_/; use vars qw(%input_expr %output_expr $ProtoUsed @InitFileCode $FH $proto_re $Overload $errors $Fallback $cplusplus $hiertype $WantPrototypes $WantVersionChk $except $WantLineNumbers @@ -210,7 +211,7 @@ sub process_file { $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn) foreach my $key (keys %output_expr) { - # We can still bootstrap compile 're', because in code re.pm is + # We can still bootstrap compile 're', because in code re.pm is # available to miniperl, and does not attempt to load the XS code. use re 'eval'; @@ -355,6 +356,15 @@ S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) #endif +/* NOTE: the prototype of newXSproto() is different in versions of perls, + * so we define a portable version of newXSproto() + */ +#ifdef newXS_flags +#define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0) +#else +#define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv) +#endif /* !defined(newXS_flags) */ + EOF print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers; @@ -438,7 +448,7 @@ EOF $xsreturn = 0; $_ = shift(@line); - while (my $kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE")) { + while (my $kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE|SCOPE")) { &{"${kwd}_handler"}() ; next PARAGRAPH unless @line ; $_ = shift(@line); @@ -848,7 +858,7 @@ EOF next; } last if $_ eq "$END:"; - death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function"); + death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function ($_)"); } print Q(<<"EOF") if $except; @@ -871,12 +881,12 @@ EOF # EOF - my $newXS = "newXS" ; - my $proto = "" ; + our $newXS = "newXS" ; + our $proto = "" ; # Build the prototype string for the xsub if ($ProtoThisXSUB) { - $newXS = "newXSproto"; + $newXS = "newXSproto_portable"; if ($ProtoThisXSUB eq 2) { # User has specified empty prototype @@ -898,23 +908,20 @@ EOF } $proto = qq{, "$proto"}; } - + if (%XsubAliases) { $XsubAliases{$pname} = 0 unless defined $XsubAliases{$pname} ; while ( ($name, $value) = each %XsubAliases) { push(@InitFileCode, Q(<<"EOF")); -# cv = newXS(\"$name\", XS_$Full_func_name, file); +# cv = ${newXS}(\"$name\", XS_$Full_func_name, file$proto); # XSANY.any_i32 = $value ; EOF - push(@InitFileCode, Q(<<"EOF")) if $proto; -# sv_setpv((SV*)cv$proto) ; -EOF } } elsif (@Attributes) { push(@InitFileCode, Q(<<"EOF")); -# cv = newXS(\"$pname\", XS_$Full_func_name, file); +# cv = ${newXS}(\"$pname\", XS_$Full_func_name, file$proto); # apply_attrs_string("$Package", cv, "@Attributes", 0); EOF } @@ -922,17 +929,14 @@ EOF while ( ($name, $value) = each %Interfaces) { $name = "$Package\::$name" unless $name =~ /::/; push(@InitFileCode, Q(<<"EOF")); -# cv = newXS(\"$name\", XS_$Full_func_name, file); +# cv = ${newXS}(\"$name\", XS_$Full_func_name, file$proto); # $interface_macro_set(cv,$value) ; EOF - push(@InitFileCode, Q(<<"EOF")) if $proto; -# sv_setpv((SV*)cv$proto) ; -EOF } } else { push(@InitFileCode, - " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n"); + " (void)${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n"); } } @@ -951,7 +955,7 @@ EOF /* Making a sub named "${Package}::()" allows the package */ /* to be findable via fetchmethod(), and causes */ /* overload::Overloaded("${Package}") to return true. */ - newXS("${Package}::()", XS_${Packid}_nil, file$proto); + (void)${newXS}("${Package}::()", XS_${Packid}_nil, file$proto); MAKE_FETCHMETHOD_WORK } @@ -984,7 +988,7 @@ EOF #so `file' is unused print Q(<<"EOF") if $Full_func_name; ##if (PERL_REVISION == 5 && PERL_VERSION < 9) -# char file[] = __FILE__; +# char* file = __FILE__; ##else # const char* file = __FILE__; ##endif @@ -1360,7 +1364,7 @@ sub OVERLOAD_handler() $Overload = 1 unless $Overload; my $overload = "$Package\::(".$1 ; push(@InitFileCode, - " newXS(\"$overload\", XS_$Full_func_name, file$proto);\n"); + " (void)${newXS}(\"$overload\", XS_$Full_func_name, file$proto);\n"); } } } @@ -1454,16 +1458,10 @@ sub SCOPE_handler () death("Error: Only 1 SCOPE declaration allowed per xsub") if $scope_in_this_xsub ++ ; - for (; !/^$BLOCK_re/o; $_ = shift(@line)) { - next unless /\S/; - TrimWhitespace($_) ; - if ($_ =~ /^DISABLE/i) { - $ScopeThisXSUB = 0 - } elsif ($_ =~ /^ENABLE/i) { - $ScopeThisXSUB = 1 - } - } - + TrimWhitespace($_); + death ("Error: SCOPE: ENABLE/DISABLE") + unless /^(ENABLE|DISABLE)\b/i; + $ScopeThisXSUB = ( uc($1) eq 'ENABLE' ); } sub PROTOTYPES_handler () @@ -1524,7 +1522,8 @@ sub INCLUDE_handler () # EOF - $filepathname = $filename = $_ ; + $filename = $_ ; + $filepathname = "$dir/$filename"; # Prime the pump by reading the first # non-blank line @@ -2080,11 +2079,24 @@ encountered during processing of the XS file. Based on xsubpp code, written by Larry Wall. -Maintained by Ken Williams, +Maintained by: + +=over 4 + +=item * + +Ken Williams, + +=item * + +David Golden, + +=back =head1 COPYRIGHT -Copyright 2002-2003 Ken Williams. All rights reserved. +Copyright 2002-2009 by Ken Williams, David Golden and other contributors. All +rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/ExtUtils-ParseXS/t/XSInclude.xsh b/cpan/ExtUtils-ParseXS/t/XSInclude.xsh new file mode 100644 index 0000000..e70ecde --- /dev/null +++ b/cpan/ExtUtils-ParseXS/t/XSInclude.xsh @@ -0,0 +1,10 @@ + +# Testing the INCLUDE keyword + +int +include_ok() +CODE: + RETVAL = 1; +OUTPUT: + RETVAL + diff --git a/cpan/ExtUtils-ParseXS/t/XSMore.xs b/cpan/ExtUtils-ParseXS/t/XSMore.xs new file mode 100644 index 0000000..173460e --- /dev/null +++ b/cpan/ExtUtils-ParseXS/t/XSMore.xs @@ -0,0 +1,117 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +=for testing + +This parts are ignored. + +=cut + +STATIC void +outlist(int* a, int* b){ + *a = 'a'; + *b = 'b'; +} + +STATIC int +len(const char* const s, int const l){ + return l; +} + +MODULE = XSMore PACKAGE = XSMore + +=for testing + +This parts are also ignored. + +=cut + +PROTOTYPES: ENABLE + +VERSIONCHECK: DISABLE + +REQUIRE: 2.20 + +SCOPE: DISABLE + +FALLBACK: TRUE + +BOOT: + sv_setiv(get_sv("XSMore::boot_ok", TRUE), 100); + + +void +prototype_ssa() +PROTOTYPE: $$@ +CODE: + NOOP; + +void +attr_method(self, ...) +ATTRS: method +CODE: + NOOP; + +#define RET_1 1 +#define RET_2 2 + +int +return_1() +CASE: ix == 1 + ALIAS: + return_1 = RET_1 + return_2 = RET_2 + CODE: + RETVAL = ix; + OUTPUT: + RETVAL +CASE: ix == 2 + CODE: + RETVAL = ix; + OUTPUT: + RETVAL + +int +arg_init(x) + int x = SvIV($arg); +CODE: + RETVAL = x; +OUTPUT: + RETVAL + +int +myabs(...) +OVERLOAD: abs +CODE: + RETVAL = 42; +OUTPUT: + RETVAL + +void +hook(IN AV* av) +INIT: + av_push(av, newSVpv("INIT", 0)); +CODE: + av_push(av, newSVpv("CODE", 0)); +POSTCALL: + av_push(av, newSVpv("POSTCALL", 0)); +CLEANUP: + av_push(av, newSVpv("CLEANUP", 0)); + + +void +outlist(OUTLIST int a, OUTLIST int b) + +int +len(char* s, int length(s)) + +#if 1 + +INCLUDE: XSInclude.xsh + +#else + +# for testing #else directive + +#endif diff --git a/cpan/ExtUtils-ParseXS/t/more.t b/cpan/ExtUtils-ParseXS/t/more.t new file mode 100644 index 0000000..8a934c2 --- /dev/null +++ b/cpan/ExtUtils-ParseXS/t/more.t @@ -0,0 +1,108 @@ +#!/usr/bin/perl + +use strict; +use Test::More; +use Config; +use DynaLoader; +use ExtUtils::CBuilder; +use attributes; +use overload; + +plan tests => 24; + +my ($source_file, $obj_file, $lib_file); + +require_ok( 'ExtUtils::ParseXS' ); +ExtUtils::ParseXS->import('process_file'); + +chdir 't' or die "Can't chdir to t/, $!"; + +use Carp; $SIG{__WARN__} = \&Carp::cluck; + +######################### + +$source_file = 'XSMore.c'; + +# Try sending to file +ExtUtils::ParseXS->process_file( + filename => 'XSMore.xs', + output => $source_file, +); +ok -e $source_file, "Create an output file"; + +my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE}; +my $b = ExtUtils::CBuilder->new(quiet => $quiet); + +SKIP: { + skip "no compiler available", 2 + if ! $b->have_compiler; + $obj_file = $b->compile( source => $source_file ); + ok $obj_file; + ok -e $obj_file, "Make sure $obj_file exists"; +} + +SKIP: { + skip "no dynamic loading", 5 + if !$b->have_compiler || !$Config{usedl}; + my $module = 'XSMore'; + $lib_file = $b->link( objects => $obj_file, module_name => $module ); + ok $lib_file; + ok -e $lib_file, "Make sure $lib_file exists"; + + eval{ + package XSMore; + our $VERSION = 42; + our $boot_ok; + DynaLoader::bootstrap_inherit(__PACKAGE__, $VERSION); # VERSIONCHECK disabled + + sub new{ bless {}, shift } + }; + is $@, ''; + is ExtUtils::ParseXS::errors(), 0, 'ExtUtils::ParseXS::errors()'; + + is $XSMore::boot_ok, 100, 'the BOOT keyword'; + + ok XSMore::include_ok(), 'the INCLUDE keyword'; + is prototype(\&XSMore::include_ok), "", 'the PROTOTYPES keyword'; + + is prototype(\&XSMore::prototype_ssa), '$$@', 'the PROTOTYPE keyword'; + + is_deeply [attributes::get(\&XSMore::attr_method)], [qw(method)], 'the ATTRS keyword'; + is prototype(\&XSMore::attr_method), '$;@', 'ATTRS with prototype'; + + is XSMore::return_1(), 1, 'the CASE keyword (1)'; + is XSMore::return_2(), 2, 'the CASE keyword (2)'; + is prototype(\&XSMore::return_1), "", 'ALIAS with prototype (1)'; + is prototype(\&XSMore::return_2), "", 'ALIAS with prototype (2)'; + + is XSMore::arg_init(200), 200, 'argument init'; + + ok overload::Overloaded(XSMore->new), 'the FALLBACK keyword'; + is abs(XSMore->new), 42, 'the OVERLOAD keyword'; + + my @a; + XSMore::hook(\@a); + is_deeply \@a, [qw(INIT CODE POSTCALL CLEANUP)], 'the INIT & POSTCALL & CLEANUP keywords'; + + is_deeply [XSMore::outlist()], [ord('a'), ord('b')], 'the OUTLIST keyword'; + + is XSMore::len("foo"), 3, 'the length keyword'; + + # 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; + } + } + } +} + +unless ($ENV{PERL_NO_CLEANUP}) { + for ( $obj_file, $lib_file, $source_file) { + next unless defined $_; + 1 while unlink $_; + } +} diff --git a/cpan/ExtUtils-ParseXS/t/typemap b/cpan/ExtUtils-ParseXS/t/typemap new file mode 100644 index 0000000..2c35437 --- /dev/null +++ b/cpan/ExtUtils-ParseXS/t/typemap @@ -0,0 +1,336 @@ +# basic C types +int T_IV +unsigned T_UV +unsigned int T_UV +long T_IV +unsigned long T_UV +short T_IV +unsigned short T_UV +char T_CHAR +unsigned char T_U_CHAR +char * T_PV +unsigned char * T_PV +const char * T_PV +caddr_t T_PV +wchar_t * T_PV +wchar_t T_IV +# bool_t is defined in +bool_t T_IV +size_t T_UV +ssize_t T_IV +time_t T_NV +unsigned long * T_OPAQUEPTR +char ** T_PACKEDARRAY +void * T_PTR +Time_t * T_PV +SV * T_SV +SVREF T_SVREF +AV * T_AVREF +HV * T_HVREF +CV * T_CVREF + +IV T_IV +UV T_UV +NV T_NV +I32 T_IV +I16 T_IV +I8 T_IV +STRLEN T_UV +U32 T_U_LONG +U16 T_U_SHORT +U8 T_UV +Result T_U_CHAR +Boolean T_BOOL +float T_FLOAT +double T_DOUBLE +SysRet T_SYSRET +SysRetLong T_SYSRET +FILE * T_STDIO +PerlIO * T_INOUT +FileHandle T_PTROBJ +InputStream T_IN +InOutStream T_INOUT +OutputStream T_OUT +bool T_BOOL + +############################################################################# +INPUT +T_SV + $var = $arg +T_SVREF + if (SvROK($arg)) + $var = (SV*)SvRV($arg); + else + Perl_croak(aTHX_ \"%s: %s is not a reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\") +T_AVREF + if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVAV) + $var = (AV*)SvRV($arg); + else + Perl_croak(aTHX_ \"%s: %s is not an array reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\") +T_HVREF + if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVHV) + $var = (HV*)SvRV($arg); + else + Perl_croak(aTHX_ \"%s: %s is not a hash reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\") +T_CVREF + if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVCV) + $var = (CV*)SvRV($arg); + else + Perl_croak(aTHX_ \"%s: %s is not a code reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\") +T_SYSRET + $var NOT IMPLEMENTED +T_UV + $var = ($type)SvUV($arg) +T_IV + $var = ($type)SvIV($arg) +T_INT + $var = (int)SvIV($arg) +T_ENUM + $var = ($type)SvIV($arg) +T_BOOL + $var = (bool)SvTRUE($arg) +T_U_INT + $var = (unsigned int)SvUV($arg) +T_SHORT + $var = (short)SvIV($arg) +T_U_SHORT + $var = (unsigned short)SvUV($arg) +T_LONG + $var = (long)SvIV($arg) +T_U_LONG + $var = (unsigned long)SvUV($arg) +T_CHAR + $var = (char)*SvPV_nolen($arg) +T_U_CHAR + $var = (unsigned char)SvUV($arg) +T_FLOAT + $var = (float)SvNV($arg) +T_NV + $var = ($type)SvNV($arg) +T_DOUBLE + $var = (double)SvNV($arg) +T_PV + $var = ($type)SvPV_nolen($arg) +T_PTR + $var = INT2PTR($type,SvIV($arg)) +T_PTRREF + if (SvROK($arg)) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type,tmp); + } + else + Perl_croak(aTHX_ \"%s: %s is not a reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\") +T_REF_IV_REF + if (sv_isa($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = *INT2PTR($type *, tmp); + } + else + Perl_croak(aTHX_ \"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\") +T_REF_IV_PTR + if (sv_isa($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type, tmp); + } + else + Perl_croak(aTHX_ \"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\") +T_PTROBJ + if (sv_derived_from($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type,tmp); + } + else + Perl_croak(aTHX_ \"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\") +T_PTRDESC + if (sv_isa($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + ${type}_desc = (\U${type}_DESC\E*) tmp; + $var = ${type}_desc->ptr; + } + else + Perl_croak(aTHX_ \"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\") +T_REFREF + if (SvROK($arg)) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = *INT2PTR($type,tmp); + } + else + Perl_croak(aTHX_ \"%s: %s is not a reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\") +T_REFOBJ + if (sv_isa($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = *INT2PTR($type,tmp); + } + else + Perl_croak(aTHX_ \"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\") +T_OPAQUE + $var = *($type *)SvPV_nolen($arg) +T_OPAQUEPTR + $var = ($type)SvPV_nolen($arg) +T_PACKED + $var = XS_unpack_$ntype($arg) +T_PACKEDARRAY + $var = XS_unpack_$ntype($arg) +T_CALLBACK + $var = make_perl_cb_$type($arg) +T_ARRAY + U32 ix_$var = $argoff; + $var = $ntype(items -= $argoff); + while (items--) { + DO_ARRAY_ELEM; + ix_$var++; + } + /* this is the number of elements in the array */ + ix_$var -= $argoff +T_STDIO + $var = PerlIO_findFILE(IoIFP(sv_2io($arg))) +T_IN + $var = IoIFP(sv_2io($arg)) +T_INOUT + $var = IoIFP(sv_2io($arg)) +T_OUT + $var = IoOFP(sv_2io($arg)) +############################################################################# +OUTPUT +T_SV + $arg = $var; +T_SVREF + $arg = newRV((SV*)$var); +T_AVREF + $arg = newRV((SV*)$var); +T_HVREF + $arg = newRV((SV*)$var); +T_CVREF + $arg = newRV((SV*)$var); +T_IV + sv_setiv($arg, (IV)$var); +T_UV + sv_setuv($arg, (UV)$var); +T_INT + sv_setiv($arg, (IV)$var); +T_SYSRET + if ($var != -1) { + if ($var == 0) + sv_setpvn($arg, "0 but true", 10); + else + sv_setiv($arg, (IV)$var); + } +T_ENUM + sv_setiv($arg, (IV)$var); +T_BOOL + $arg = boolSV($var); +T_U_INT + sv_setuv($arg, (UV)$var); +T_SHORT + sv_setiv($arg, (IV)$var); +T_U_SHORT + sv_setuv($arg, (UV)$var); +T_LONG + sv_setiv($arg, (IV)$var); +T_U_LONG + sv_setuv($arg, (UV)$var); +T_CHAR + sv_setpvn($arg, (char *)&$var, 1); +T_U_CHAR + sv_setuv($arg, (UV)$var); +T_FLOAT + sv_setnv($arg, (double)$var); +T_NV + sv_setnv($arg, (NV)$var); +T_DOUBLE + sv_setnv($arg, (double)$var); +T_PV + sv_setpv((SV*)$arg, $var); +T_PTR + sv_setiv($arg, PTR2IV($var)); +T_PTRREF + sv_setref_pv($arg, Nullch, (void*)$var); +T_REF_IV_REF + sv_setref_pv($arg, \"${ntype}\", (void*)new $ntype($var)); +T_REF_IV_PTR + sv_setref_pv($arg, \"${ntype}\", (void*)$var); +T_PTROBJ + sv_setref_pv($arg, \"${ntype}\", (void*)$var); +T_PTRDESC + sv_setref_pv($arg, \"${ntype}\", (void*)new\U${type}_DESC\E($var)); +T_REFREF + NOT_IMPLEMENTED +T_REFOBJ + NOT IMPLEMENTED +T_OPAQUE + sv_setpvn($arg, (char *)&$var, sizeof($var)); +T_OPAQUEPTR + sv_setpvn($arg, (char *)$var, sizeof(*$var)); +T_PACKED + XS_pack_$ntype($arg, $var); +T_PACKEDARRAY + XS_pack_$ntype($arg, $var, count_$ntype); +T_DATAUNIT + sv_setpvn($arg, $var.chp(), $var.size()); +T_CALLBACK + sv_setpvn($arg, $var.context.value().chp(), + $var.context.value().size()); +T_ARRAY + { + U32 ix_$var; + EXTEND(SP,size_$var); + for (ix_$var = 0; ix_$var < size_$var; ix_$var++) { + ST(ix_$var) = sv_newmortal(); + DO_ARRAY_ELEM + } + } +T_STDIO + { + GV *gv = newGVgen("$Package"); + PerlIO *fp = PerlIO_importFILE($var,0); + if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } +T_IN + { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } +T_INOUT + { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } +T_OUT + { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + }