More compatibility testing

3 files changed, 506 insertions, 16 deletions

diff --git a/dist/ExtUtils-ParseXS/t/600-t-compat.t b/dist/ExtUtils-ParseXS/t/600-t-compat.t
index cc623cd8cf..6cc6678e1e 100644
--- a/dist/ExtUtils-ParseXS/t/600-t-compat.t
+++ b/dist/ExtUtils-ParseXS/t/600-t-compat.t
@@ -2,7 +2,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 1;
+use Test::More;
 
 # This test is for making sure that the new EU::Typemaps
 # based typemap merging produces the same result as the old
@@ -19,15 +19,50 @@ use ExtUtils::ParseXS::Constants;
 use File::Spec;
 
 my $path_prefix = File::Spec->catdir(-d 't' ? qw(t data) : qw(data));
-my @local_tmaps = (
-  File::Spec->catdir($path_prefix, "conflicting.typemap"),
+
+my @tests = (
+  {
+    name => 'Simple conflict',
+    local_maps => [
+      File::Spec->catdir($path_prefix, "conflicting.typemap"),
+    ],
+    std_maps => [
+      File::Spec->catdir($path_prefix, "other.typemap"),
+    ],
+  },
+  {
+    name => 'B',
+    local_maps => [
+      File::Spec->catdir($path_prefix, "b.typemap"),
+    ],
+    std_maps => [],
+  },
+  {
+    name => 'B and perl',
+    local_maps => [
+      File::Spec->catdir($path_prefix, "b.typemap"),
+    ],
+    std_maps => [
+      File::Spec->catdir($path_prefix, "perl.typemap"),
+    ],
+  },
+  {
+    name => 'B and perl and B again',
+    local_maps => [
+      File::Spec->catdir($path_prefix, "b.typemap"),
+    ],
+    std_maps => [
+      File::Spec->catdir($path_prefix, "perl.typemap"),
+      File::Spec->catdir($path_prefix, "b.typemap"),
+    ],
+  },
 );
+plan tests => scalar(@tests);
 
+my @local_tmaps;
+my @standard_typemap_locations;
 SCOPE: {
   no warnings 'redefine';
-  my @standard_typemap_locations = (
-    File::Spec->catdir($path_prefix, "other.typemap"),
-  );
   sub ExtUtils::ParseXS::Utilities::standard_typemap_locations {
     @standard_typemap_locations;
   }
@@ -36,21 +71,28 @@ SCOPE: {
   }
 }
 
-my $res = [_process_typemaps([@local_tmaps], '.')];
-my $res_new = [process_typemaps([@local_tmaps], '.')];
+foreach my $test (@tests) {
+  @local_tmaps = @{ $test->{local_maps} };
+  @standard_typemap_locations = @{ $test->{std_maps} };
+
+  my $res = [_process_typemaps([@local_tmaps], '.')];
+  my $res_new = [process_typemaps([@local_tmaps], '.')];
 
-# Normalize trailing whitespace. Let's be that lenient, mkay?
-for ($res, $res_new) {
-  for ($_->[2], $_->[3]) {
-    for (values %$_) {
-      s/\s+\z//;
+  # Normalize trailing whitespace. Let's be that lenient, mkay?
+  for ($res, $res_new) {
+    for ($_->[2], $_->[3]) {
+      for (values %$_) {
+        s/\s+\z//;
+      }
     }
   }
+  #use Data::Dumper; warn Dumper $res;
+  #use Data::Dumper; warn Dumper $res_new;
+
+  is_deeply($res_new, $res, "typemap equivalency for '$test->{name}'");
 }
-#use Data::Dumper; warn Dumper $res;
-#use Data::Dumper; warn Dumper $res_new;
 
-is_deeply($res_new, $res);
+
 
 sub _process_typemaps {
   my ($tmap, $pwd) = @_;
diff --git a/dist/ExtUtils-ParseXS/t/data/b.typemap b/dist/ExtUtils-ParseXS/t/data/b.typemap
new file mode 100644
index 0000000000..5e342749d2
--- /dev/null
+++ b/dist/ExtUtils-ParseXS/t/data/b.typemap
@@ -0,0 +1,88 @@
+TYPEMAP
+
+B::OP		T_OP_OBJ
+B::UNOP		T_OP_OBJ
+B::BINOP	T_OP_OBJ
+B::LOGOP	T_OP_OBJ
+B::LISTOP	T_OP_OBJ
+B::PMOP		T_OP_OBJ
+B::SVOP		T_OP_OBJ
+B::PADOP	T_OP_OBJ
+B::PVOP		T_OP_OBJ
+B::LOOP		T_OP_OBJ
+B::COP		T_OP_OBJ
+
+B::SV		T_SV_OBJ
+B::PV		T_SV_OBJ
+B::IV		T_SV_OBJ
+B::NV		T_SV_OBJ
+B::PVMG		T_SV_OBJ
+B::REGEXP	T_SV_OBJ
+B::PVLV		T_SV_OBJ
+B::BM		T_SV_OBJ
+B::RV		T_SV_OBJ
+B::GV		T_SV_OBJ
+B::CV		T_SV_OBJ
+B::HV		T_SV_OBJ
+B::AV		T_SV_OBJ
+B::IO		T_SV_OBJ
+B::FM		T_SV_OBJ
+
+B::MAGIC	T_MG_OBJ
+SSize_t		T_IV
+STRLEN		T_UV
+PADOFFSET	T_UV
+
+B::HE		T_HE_OBJ
+B::RHE		T_RHE_OBJ
+
+INPUT
+T_OP_OBJ
+	if (SvROK($arg)) {
+	    IV tmp = SvIV((SV*)SvRV($arg));
+	    $var = INT2PTR($type,tmp);
+	}
+	else
+	    croak(\"$var is not a reference\")
+
+T_SV_OBJ
+	if (SvROK($arg)) {
+	    IV tmp = SvIV((SV*)SvRV($arg));
+	    $var = INT2PTR($type,tmp);
+	}
+	else
+	    croak(\"$var is not a reference\")
+
+T_MG_OBJ
+	if (SvROK($arg)) {
+	    IV tmp = SvIV((SV*)SvRV($arg));
+	    $var = INT2PTR($type,tmp);
+	}
+	else
+	    croak(\"$var is not a reference\")
+
+T_HE_OBJ
+	if (SvROK($arg)) {
+	    IV tmp = SvIV((SV*)SvRV($arg));
+	    $var = INT2PTR($type,tmp);
+	}
+	else
+	    croak(\"$var is not a reference\")
+
+T_RHE_OBJ
+	if (SvROK($arg)) {
+	    IV tmp = SvIV((SV*)SvRV($arg));
+	    $var = INT2PTR($type,tmp);
+	}
+	else
+	    croak(\"$var is not a reference\")
+
+OUTPUT
+T_MG_OBJ
+	sv_setiv(newSVrv($arg, "B::MAGIC"), PTR2IV($var));
+
+T_HE_OBJ
+	sv_setiv(newSVrv($arg, "B::HE"), PTR2IV($var));
+
+T_RHE_OBJ
+	sv_setiv(newSVrv($arg, "B::RHE"), PTR2IV($var));
diff --git a/dist/ExtUtils-ParseXS/t/data/perl.typemap b/dist/ExtUtils-ParseXS/t/data/perl.typemap
new file mode 100644
index 0000000000..c88238a48d
--- /dev/null
+++ b/dist/ExtUtils-ParseXS/t/data/perl.typemap
@@ -0,0 +1,360 @@
+# 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
+	STMT_START {
+		SV* const xsub_tmp_sv = $arg;
+		SvGETMAGIC(xsub_tmp_sv);
+		if (SvROK(xsub_tmp_sv)){
+		    $var = SvRV(xsub_tmp_sv);
+		}
+		else{
+		    Perl_croak(aTHX_ \"%s: %s is not a reference\",
+				${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+				\"$var\");
+		}
+	} STMT_END
+T_AVREF
+	STMT_START {
+		SV* const xsub_tmp_sv = $arg;
+		SvGETMAGIC(xsub_tmp_sv);
+		if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVAV){
+		    $var = (AV*)SvRV(xsub_tmp_sv);
+		}
+		else{
+		    Perl_croak(aTHX_ \"%s: %s is not an ARRAY reference\",
+				${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+				\"$var\");
+		}
+	} STMT_END
+T_HVREF
+	STMT_START {
+		SV* const xsub_tmp_sv = $arg;
+		SvGETMAGIC(xsub_tmp_sv);
+		if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVHV){
+		    $var = (HV*)SvRV(xsub_tmp_sv);
+		}
+		else{
+		    Perl_croak(aTHX_ \"%s: %s is not a HASH reference\",
+				${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+				\"$var\");
+		}
+	} STMT_END
+T_CVREF
+	STMT_START {
+		SV* const xsub_tmp_sv = $arg;
+		SvGETMAGIC(xsub_tmp_sv);
+		if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVCV){
+		    $var = (CV*)SvRV(xsub_tmp_sv);
+		}
+		else{
+		    Perl_croak(aTHX_ \"%s: %s is not a CODE reference\",
+				${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+				\"$var\");
+		}
+	} STMT_END
+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 (SvROK($arg) && 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;
+	}