r46064 - in /branches/upstream/libextutils-parsexs-perl/current: Changes MANIFEST META.yml README lib/ExtUtils/ParseXS.pm t/XSInclude.xsh t/XSMore.xs t/more.t t/typemap

jawnsy-guest at users.alioth.debian.org jawnsy-guest at users.alioth.debian.org
Sun Oct 18 22:20:17 UTC 2009


Author: jawnsy-guest
Date: Sun Oct 18 22:20:10 2009
New Revision: 46064

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=46064
Log:
[svn-upgrade] Integrating new upstream version, libextutils-parsexs-perl (2.210000)

Added:
    branches/upstream/libextutils-parsexs-perl/current/t/XSInclude.xsh
    branches/upstream/libextutils-parsexs-perl/current/t/XSMore.xs
    branches/upstream/libextutils-parsexs-perl/current/t/more.t
    branches/upstream/libextutils-parsexs-perl/current/t/typemap
Modified:
    branches/upstream/libextutils-parsexs-perl/current/Changes
    branches/upstream/libextutils-parsexs-perl/current/MANIFEST
    branches/upstream/libextutils-parsexs-perl/current/META.yml
    branches/upstream/libextutils-parsexs-perl/current/README
    branches/upstream/libextutils-parsexs-perl/current/lib/ExtUtils/ParseXS.pm

Modified: branches/upstream/libextutils-parsexs-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libextutils-parsexs-perl/current/Changes?rev=46064&op=diff
==============================================================================
--- branches/upstream/libextutils-parsexs-perl/current/Changes (original)
+++ branches/upstream/libextutils-parsexs-perl/current/Changes Sun Oct 18 22:20:10 2009
@@ -1,4 +1,35 @@
 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
 
@@ -18,6 +49,7 @@
 
  - No changes from 2.20_04.
 
+
 2.20_04 - Mon Aug 10 11:18:47 EDT 2009
 
  Bug fixes:
@@ -30,8 +62,8 @@
 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]
 

Modified: branches/upstream/libextutils-parsexs-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libextutils-parsexs-perl/current/MANIFEST?rev=46064&op=diff
==============================================================================
--- branches/upstream/libextutils-parsexs-perl/current/MANIFEST (original)
+++ branches/upstream/libextutils-parsexs-perl/current/MANIFEST Sun Oct 18 22:20:10 2009
@@ -12,7 +12,11 @@
 t/bugs/typemap
 t/include/nscore.h
 t/include/nsUniversalDetector.h
+t/more.t
+t/typemap
 t/usage.t
+t/XSInclude.xsh
+t/XSMore.xs
 t/XSTest.pm
 t/XSTest.xs
 t/XSUsage.pm

Modified: branches/upstream/libextutils-parsexs-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libextutils-parsexs-perl/current/META.yml?rev=46064&op=diff
==============================================================================
--- branches/upstream/libextutils-parsexs-perl/current/META.yml (original)
+++ branches/upstream/libextutils-parsexs-perl/current/META.yml Sun Oct 18 22:20:10 2009
@@ -1,8 +1,9 @@
 ---
 name: ExtUtils-ParseXS
-version: 2.200403
+version: 2.21
 author:
-  - 'Maintained by Ken Williams, <ken at mathforum.org>'
+  - 'Ken Williams, <ken at mathforum.org>'
+  - 'David Golden, <dagolden at cpan.org>'
 abstract: converts Perl XS code into C code
 license: perl
 resources:
@@ -24,7 +25,7 @@
 provides:
   ExtUtils::ParseXS:
     file: lib/ExtUtils/ParseXS.pm
-    version: 2.200403
+    version: 2.21
 generated_by: Module::Build version 0.3502
 meta-spec:
   url: http://module-build.sourceforge.net/META-spec-v1.4.html

Modified: branches/upstream/libextutils-parsexs-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libextutils-parsexs-perl/current/README?rev=46064&op=diff
==============================================================================
--- branches/upstream/libextutils-parsexs-perl/current/README (original)
+++ branches/upstream/libextutils-parsexs-perl/current/README Sun Oct 18 22:20:10 2009
@@ -92,10 +92,15 @@
 AUTHOR
     Based on xsubpp code, written by Larry Wall.
 
-    Maintained by Ken Williams, <ken at mathforum.org>
+    Maintained by:
+
+    *   Ken Williams, <ken at mathforum.org>
+
+    *   David Golden, <dagolden at cpan.org>
 
 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.

Modified: branches/upstream/libextutils-parsexs-perl/current/lib/ExtUtils/ParseXS.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libextutils-parsexs-perl/current/lib/ExtUtils/ParseXS.pm?rev=46064&op=diff
==============================================================================
--- branches/upstream/libextutils-parsexs-perl/current/lib/ExtUtils/ParseXS.pm (original)
+++ branches/upstream/libextutils-parsexs-perl/current/lib/ExtUtils/ParseXS.pm Sun Oct 18 22:20:10 2009
@@ -18,7 +18,8 @@
 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
@@ -354,6 +355,15 @@
 #endif
 
 #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
 
@@ -438,7 +448,7 @@
     $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 @@
 	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
 
-    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 @@
       }
       $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 @@
       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 @@
     /* 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 @@
   #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 @@
       $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 @@
     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 @@
 #
 EOF
 
-    $filepathname = $filename = $_ ;
+    $filename = $_ ;
+    $filepathname = "$dir/$filename";
 
     # Prime the pump by reading the first
     # non-blank line
@@ -2080,11 +2079,24 @@
 
 Based on xsubpp code, written by Larry Wall.
 
-Maintained by Ken Williams, <ken at mathforum.org>
+Maintained by: 
+
+=over 4
+
+=item *
+
+Ken Williams, <ken at mathforum.org>
+
+=item *
+
+David Golden, <dagolden at cpan.org>
+
+=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.

Added: branches/upstream/libextutils-parsexs-perl/current/t/XSInclude.xsh
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libextutils-parsexs-perl/current/t/XSInclude.xsh?rev=46064&op=file
==============================================================================
--- branches/upstream/libextutils-parsexs-perl/current/t/XSInclude.xsh (added)
+++ branches/upstream/libextutils-parsexs-perl/current/t/XSInclude.xsh Sun Oct 18 22:20:10 2009
@@ -1,0 +1,10 @@
+
+# Testing the INCLUDE keyword
+
+int
+include_ok()
+CODE:
+	RETVAL = 1;
+OUTPUT:
+	RETVAL
+

Added: branches/upstream/libextutils-parsexs-perl/current/t/XSMore.xs
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libextutils-parsexs-perl/current/t/XSMore.xs?rev=46064&op=file
==============================================================================
--- branches/upstream/libextutils-parsexs-perl/current/t/XSMore.xs (added)
+++ branches/upstream/libextutils-parsexs-perl/current/t/XSMore.xs Sun Oct 18 22:20:10 2009
@@ -1,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

Added: branches/upstream/libextutils-parsexs-perl/current/t/more.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libextutils-parsexs-perl/current/t/more.t?rev=46064&op=file
==============================================================================
--- branches/upstream/libextutils-parsexs-perl/current/t/more.t (added)
+++ branches/upstream/libextutils-parsexs-perl/current/t/more.t Sun Oct 18 22:20:10 2009
@@ -1,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 $_;
+  }
+}

Added: branches/upstream/libextutils-parsexs-perl/current/t/typemap
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libextutils-parsexs-perl/current/t/typemap?rev=46064&op=file
==============================================================================
--- branches/upstream/libextutils-parsexs-perl/current/t/typemap (added)
+++ branches/upstream/libextutils-parsexs-perl/current/t/typemap Sun Oct 18 22:20:10 2009
@@ -1,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 <rpc/rpc.h>
+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;
+	}




More information about the Pkg-perl-cvs-commits mailing list