1 files changed, 148 insertions, 219 deletions

diff --git a/ext/xsubpp b/ext/xsubpp
index e7a710be2a..d2be4f5619 100755
--- a/ext/xsubpp
+++ b/ext/xsubpp
@@ -1,177 +1,78 @@
-#!/usr/bin/perl
+#!./perl
 # $Header$ 
 
-$usage = "Usage: xsubpp [-a] [-s] [-c] typemap file.xs\n";
-die $usage unless (@ARGV >= 2 && @ARGV <= 6);
+$usage = "Usage: xsubpp [-ansi] [-C++] [-except] [-tm typemap] file.xs\n";
 
-SWITCH: while ($ARGV[0] =~ /^-/) {
+SWITCH: while ($ARGV[0] =~ s/^-//) {
     $flag = shift @ARGV;
-    $aflag = 1, next SWITCH if $flag =~ /^-a$/;
-    $spat = $1, next SWITCH if $flag =~ /^-s(.*)$/;
-    $cflag = 1, next SWITCH if $flag =~ /^-c$/;
-    $eflag = 1, next SWITCH if $flag =~ /^-e$/;
+    $ansiflag = 1,	next SWITCH	if $flag eq 'ansi';
+    $spat = shift,	next SWITCH	if $flag eq 's';
+    $cplusplus = 1,	next SWITCH	if $flag eq 'C++';
+    $except = 1,	next SWITCH	if $flag eq 'except';
+    push(@tm,shift),	next SWITCH	if $flag eq 'typemap';
     die $usage;
 }
+@ARGV == 1 or die $usage;
+chop($pwd = `pwd`);
+($dir, $filename) = @ARGV[0] =~ m#(.*)/(.*)#
+	or ($dir, $filename) = ('.', $ARGV[0]);
+chdir($dir);
 
 $typemap = shift @ARGV;
-open(TYPEMAP, $typemap) || die "cannot open $typemap\n";
-while (<TYPEMAP>) {
-	next if /^\s*$/ || /^#/;
-	chop;
-	($typename, $kind) = split(/\t+/, $_, 2);
-	$type_kind{$typename} = $kind;
+foreach $typemap (@tm) {
+    die "Can't find $typemap in $pwd\n" unless -r $typemap;
 }
-close(TYPEMAP);
-
-%input_expr = (JUNK, split(/\n(T_\w*)\s*\n/, <<'T_END'));
-
-T_INT
-	$var = (int)SvIV($arg)
-T_ENUM
-	$var = ($type)SvIV($arg)
-T_U_INT
-	$var = (unsigned int)SvIV($arg)
-T_SHORT
-	$var = (short)SvIV($arg)
-T_U_SHORT
-	$var = (unsigned short)SvIV($arg)
-T_LONG
-	$var = (long)SvIV($arg)
-T_U_LONG
-	$var = (unsigned long)SvIV($arg)
-T_CHAR
-	$var = (char)*SvPV($arg,na)
-T_U_CHAR
-	$var = (unsigned char)SvIV($arg)
-T_FLOAT
-	$var = (float)SvNV($arg)
-T_DOUBLE
-	$var = SvNV($arg)
-T_STRING
-	$var = SvPV($arg,na)
-T_PTR
-	$var = ($type)(unsigned long)SvNV($arg)
-T_PTRREF
-	if (SvROK($arg))
-	    $var = ($type)(unsigned long)SvNV((SV*)SvRV($arg));
-	else
-	    croak(\"$var is not a reference\")
-T_PTROBJ
-	if (sv_isa($arg, \"${ntype}\"))
-	    $var = ($type)(unsigned long)SvNV((SV*)SvRV($arg));
-	else
-	    croak(\"$var is not of type ${ntype}\")
-T_PTRDESC
-	if (sv_isa($arg, \"${ntype}\")) {
-	    ${type}_desc = (\U${type}_DESC\E*)(unsigned long)SvNV((SV*)SvRV($arg));
-	    $var = ${type}_desc->ptr;
+unshift @tm, qw(../../../typemap ../../typemap ../typemap typemap);
+foreach $typemap (@tm) {
+    open(TYPEMAP, $typemap) || next;
+    $mode = Typemap;
+    $current = \$junk;
+    while (<TYPEMAP>) {
+	next if /^#/;
+	if (/^INPUT\s*$/) { $mode = Input, next }
+	if (/^OUTPUT\s*$/) { $mode = Output, next }
+	if (/^TYPEMAP\s*$/) { $mode = Typemap, next }
+	if ($mode eq Typemap) {
+	    chop;
+	    ($typename, $kind) = split(/\t+/, $_, 2);
+	    $type_kind{$typename} = $kind if $kind ne '';
 	}
-	else
-	    croak(\"$var is not of type ${ntype}\")
-T_REFREF
-	if (SvROK($arg))
-	    $var = *($type)(unsigned long)SvNV((SV*)SvRV($arg));
-	else
-	    croak(\"$var is not a reference\")
-T_REFOBJ
-	if (sv_isa($arg, \"${ntype}\"))
-	    $var = *($type)(unsigned long)SvNV((SV*)SvRV($arg));
-	else
-	    croak(\"$var is not of type ${ntype}\")
-T_OPAQUE
-	$var NOT IMPLEMENTED
-T_OPAQUEPTR
-	$var = ($type)SvPV($arg,na)
-T_PACKED
-	$var = XS_unpack_$ntype($arg)
-T_PACKEDARRAY
-	$var = XS_unpack_$ntype($arg)
-T_CALLBACK
-	$var = make_perl_cb_$type($arg)
-T_ARRAY
-	$var = $ntype(items -= $argoff);
-	U32 ix_$var = $argoff;
-	while (items--) {
-	    DO_ARRAY_ELEM;
+	elsif ($mode eq Input) {
+	    if (/^\s/) {
+		$$current .= $_;
+	    }
+	    else {
+		s/\s*$//;
+#		$input_expr{$_} = '';
+		$current = \$input_expr{$_};
+	    }
 	}
-T_DATUM
-	$var.dptr = SvPV($arg, $var.dsize);
-T_GDATUM
-	UNIMPLEMENTED
-T_PLACEHOLDER
-T_END
-
-$* = 1; %output_expr = (JUNK, split(/^(T_\w*)\s*\n/, <<'T_END')); $* = 0;
-T_INT
-	sv_setiv($arg, (I32)$var);
-T_ENUM
-	sv_setiv($arg, (I32)$var);
-T_U_INT
-	sv_setiv($arg, (I32)$var);
-T_SHORT
-	sv_setiv($arg, (I32)$var);
-T_U_SHORT
-	sv_setiv($arg, (I32)$var);
-T_LONG
-	sv_setiv($arg, (I32)$var);
-T_U_LONG
-	sv_setiv($arg, (I32)$var);
-T_CHAR
-	sv_setpvn($arg, (char *)&$var, 1);
-T_U_CHAR
-	sv_setiv($arg, (I32)$var);
-T_FLOAT
-	sv_setnv($arg, (double)$var);
-T_DOUBLE
-	sv_setnv($arg, $var);
-T_STRING
-	sv_setpv($arg, $var);
-T_PTR
-	sv_setnv($arg, (double)(unsigned long)$var);
-T_PTRREF
-	sv_setptrref($arg, $var);
-T_PTROBJ
-	sv_setptrobj($arg, $var, \"${ntype}\");
-T_PTRDESC
-	sv_setptrobj($arg, (void*)new\U${type}_DESC\E($var), \"${ntype}\");
-T_REFREF
-	sv_setrefref($arg, \"${ntype}\", XS_service_$ntype,
-		    ($var ? (void*)new $ntype($var) : 0));
-T_REFOBJ
-	NOT IMPLEMENTED
-T_OPAQUE
-	sv_setpvn($arg, (char *)&$var, sizeof($var));
-T_OPAQUEPTR
-	sv_setpvn($arg, (char *)$var, sizeof(*$var)), XFree((char *)$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
-	ST_EXTEND($var.size);
-	for (U32 ix_$var = 0; ix_$var < $var.size; ix_$var++) {
-		ST(ix_$var) = sv_mortalcopy(&sv_undef);
-	DO_ARRAY_ELEM
+	else {
+	    if (/^\s/) {
+		$$current .= $_;
+	    }
+	    else {
+		s/\s*$//;
+#		$output_expr{$_} = '';
+		$current = \$output_expr{$_};
+	    }
 	}
-	sp += $var.size - 1;
-T_DATUM
-	sv_setpvn($arg, $var.dptr, $var.dsize);
-T_GDATUM
-	sv_usepvn($arg, $var.dptr, $var.dsize);
-T_END
+    }
+    close(TYPEMAP);
+}
 
-$uvfile = shift @ARGV;
-open(F, $uvfile) || die "cannot open $uvfile\n";
+foreach $key (keys %input_expr) {
+    $input_expr{$key} =~ s/\n+$//;
+}
 
-if ($eflag) {
-	print qq|#include "cfm/basic.h"\n|;
+sub Q {
+    local $text = shift;
+    $text =~ tr/#//d;
+    $text;
 }
 
+open(F, $filename) || die "cannot open $filename\n";
+
 while (<F>) {
 	last if ($Module, $foo, $Package, $foo1, $Prefix) =
 		/^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(.+))?$/;
@@ -196,7 +97,7 @@ while (<F>) {
 		$Package .= "::" if defined $Package && $Package ne "";
 		next;
 	}
-	split(/[\t ]*\n/);
+	@line = split(/[\t ]*\n/);
 
 	# initialize info arrays
 	undef(%args_match);
@@ -208,12 +109,12 @@ while (<F>) {
 	undef($elipsis);
 
 	# extract return type, function name and arguments
-	$ret_type = shift(@_);
+	$ret_type = shift(@line);
 	if ($ret_type =~ /^static\s+(.*)$/) {
 		$static = 1;
 		$ret_type = $1;
 	}
-	$func_header = shift(@_);
+	$func_header = shift(@line);
 	($func_name, $orig_args) =  $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
 	if ($func_name =~ /(.*)::(.*)/) {
 		$class = $1;
@@ -254,39 +155,47 @@ while (<F>) {
 	@args_match{@args} = 1..@args;
 
 	# print function header
-	print <<"EOF" if $aflag;
-static int
-XS_${Pack}_$func_name(int, int sp, int items)
+	if ($ansiflag) {
+	    print Q<<"EOF";
+#static int
+#XS_${Pack}_$func_name(int, int ax, int items)
 EOF
-	print <<"EOF" if !$aflag;
-static int
-XS_${Pack}_$func_name(ix, sp, items)
-register int ix;
-register int sp;
-register int items;
-EOF
-	print <<"EOF" if $elipsis;
-{
-    if (items < $min_args) {
-	croak("Usage: $pname($orig_args)");
-    }
+	}
+	else {
+	    print Q<<"EOF";
+#static int
+#XS_${Pack}_$func_name(ix, ax, items)
+#register int ix;
+#register int ax;
+#register int items;
 EOF
-	print <<"EOF" if !$elipsis;
-{
-    if (items < $min_args || items > $num_args) {
-	croak("Usage: $pname($orig_args)");
-    }
+	}
+	if ($elipsis) {
+	    $cond = qq(items < $min_args);
+	}
+	elsif ($min_args == $num_args) {
+	    $cond = qq(items != $min_args);
+	}
+	else {
+	    $cond = qq(items < $min_args || items > $num_args);
+	}
+
+print Q<<"EOF";
+#{
+#    if ($cond) {
+#	croak("Usage: $pname($orig_args)");
+#    }
 EOF
 
 # Now do a block of some sort.
 
 $condnum = 0;
-if (!@_) {
-    @_ = "CLEANUP:";
+if (!@line) {
+    @line = "CLEANUP:";
 }
-while (@_) {
+while (@line) {
 	if ($_[0] =~ s/^\s*CASE\s*:\s*//) {
-		$cond = shift(@_);
+		$cond = shift(@line);
 		if ($condnum == 0) {
 		    print "    if ($cond)\n";
 		}
@@ -299,18 +208,24 @@ while (@_) {
 		$condnum++;
 	}
 
-	print 		<<"EOF" if $eflag;
-    TRY {
+	if ($except) {
+	    print Q<<"EOF";
+#    char errbuf[1024];
+#    *errbuf = '\0';
+#    TRY {
 EOF
-	print 		<<"EOF" if !$eflag;
-    {
+	}
+	else {
+	    print Q<<"EOF";
+#    {
 EOF
+	}
 
 	# do initialization of input variables
 	$thisdone = 0;
 	$retvaldone = 0;
 	$deferred = "";
-	while ($_ = shift(@_)) {
+	while ($_ = shift(@line)) {
 		last if /^\s*NOT_IMPLEMENTED_YET/;
 		last if /^\s*(CODE|OUTPUT|CLEANUP|CASE)\s*:/;
 		($var_type, $var_name, $var_init) =
@@ -359,7 +274,7 @@ EOF
 		}
 		print $deferred;
 		if (/^\s*CODE:/) {
-			while ($_ = shift(@_)) {
+			while ($_ = shift(@line)) {
 				last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
 				print "$_\n";
 			}
@@ -384,7 +299,7 @@ EOF
 
 	# do output variables
 	if (/^\s*OUTPUT\s*:/) {
-		while ($_ = shift(@_)) {
+		while ($_ = shift(@line)) {
 			last if /^\s*CLEANUP\s*:/;
 			s/^\s+//;
 			($outarg, $outcode) = split(/\t+/);
@@ -401,43 +316,49 @@ EOF
 	}
 	# do cleanup
 	if (/^\s*CLEANUP\s*:/) {
-	    while ($_ = shift(@_)) {
+	    while ($_ = shift(@line)) {
 		    last if /^\s*CASE\s*:/;
 		    print "$_\n";
 	    }
 	}
 	# print function trailer
-	print <<EOF if $eflag;
-    }
-    BEGHANDLERS
-    CATCHALL
-	croak("%s: %s\\tpropagated", Xname, Xreason);
-    ENDHANDLERS
+	if ($except) {
+	    print Q<<EOF;
+#    }
+#    BEGHANDLERS
+#    CATCHALL
+#	sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
+#    ENDHANDLERS
+#    if (errbuf[0])
+#	croak(errbuf);
 EOF
-	print <<EOF if !$eflag;
-    }
+	}
+	else {
+	    print Q<<EOF;
+#    }
 EOF
+	}
 	if (/^\s*CASE\s*:/) {
-	    unshift(@_, $_);
+	    unshift(@line, $_);
 	}
 }
-	print <<EOF;
-    return sp;
-}
-
+	print Q<<EOF;
+#    return ax;
+#}
+#
 EOF
 }
 
 # print initialization routine
-print qq/extern "C"\n/ if $cflag;
-print <<"EOF";
-int init_$Module(ix,sp,items)
-int ix;
-int sp;
-int items;
-{
-    char* file = __FILE__;
-
+print qq/extern "C"\n/ if $cplusplus;
+print Q<<"EOF";
+#int boot_$Module(ix,ax,items)
+#int ix;
+#int ax;
+#int items;
+#{
+#    char* file = __FILE__;
+#
 EOF
 
 for (@Func_name) {
@@ -453,18 +374,23 @@ sub output_init {
 	eval qq/print " $init\\\n"/;
 }
 
+sub blurt { warn @_; $errors++ }
+
 sub generate_init {
 	local($type, $num, $var) = @_;
 	local($arg) = "ST($num)";
 	local($argoff) = $num - 1;
 	local($ntype);
+	local($tk);
 
-	die "$type not in typemap" if !defined($type_kind{$type});
+	blurt("$type not in typemap"), return unless defined($type_kind{$type});
 	($ntype = $type) =~ s/\s*\*/Ptr/g;
 	$subtype = $ntype;
 	$subtype =~ s/Ptr$//;
 	$subtype =~ s/Array$//;
-	$expr = $input_expr{$type_kind{$type}};
+	$tk = $type_kind{$type};
+	$tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
+	$expr = $input_expr{$tk};
 	if ($expr =~ /DO_ARRAY_ELEM/) {
 	    $subexpr = $input_expr{$type_kind{$subtype}};
 	    $subexpr =~ s/ntype/subtype/g;
@@ -496,7 +422,8 @@ sub generate_output {
 	if ($type =~ /^array\(([^,]*),(.*)\)/) {
 		print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
 	} else {
-		die "$type not in typemap" if !defined($type_kind{$type});
+		blurt("$type not in typemap"), return
+		    unless defined($type_kind{$type});
 		($ntype = $type) =~ s/\s*\*/Ptr/g;
 		$ntype =~ s/\(\)//g;
 		$subtype = $ntype;
@@ -512,7 +439,7 @@ sub generate_output {
 		    $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
 		}
 		elsif ($arg eq 'ST(0)') {
-		    print "\tST(0) = sv_mortalcopy(&sv_undef);\n";
+		    print "\tST(0) = sv_newmortal();\n";
 		}
 		eval "print qq\f$expr\f";
 	}
@@ -527,3 +454,5 @@ sub map_type {
 		return $type;
 	}
 }
+
+exit $errors;