[p5sagit/p5-mst-13.2.git] / lib / ExtUtils / xsubpp

#!./miniperl
'di ';
'ds 00 \"';
'ig 00 ';
# $Header$ 

$usage = "Usage: xsubpp [-C++] [-except] [-typemap typemap] file.xs\n";

SWITCH: while ($ARGV[0] =~ s/^-//) {
    $flag = shift @ARGV;
    $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] =~ m#(.*[>\]])(.*)#
	or ($dir, $filename) = ('.', $ARGV[0]);
chdir($dir);

$typemap = shift @ARGV;
foreach $typemap (@tm) {
    die "Can't find $typemap in $pwd\n" unless -r $typemap;
}
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 '';
	}
	elsif ($mode eq Input) {
	    if (/^\s/) {
		$$current .= $_;
	    }
	    else {
		s/\s*$//;
		$input_expr{$_} = '';
		$current = \$input_expr{$_};
	    }
	}
	else {
	    if (/^\s/) {
		$$current .= $_;
	    }
	    else {
		s/\s*$//;
		$output_expr{$_} = '';
		$current = \$output_expr{$_};
	    }
	}
    }
    close(TYPEMAP);
}

foreach $key (keys %input_expr) {
    $input_expr{$key} =~ s/\n+$//;
}

sub Q {
    local $text = shift;
    $text =~ tr/#//d;
    $text =~ s/\[\[/{/g;
    $text =~ s/\]\]/}/g;
    $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*(\S+))?\s*$/;
    print $_;
}
exit 0 if $_ eq "";
$lastline = $_;

sub fetch_para {
    # parse paragraph
    @line = ();
    if ($lastline ne "") {
	if ($lastline =~
    /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/) {
	    $Module = $1;
	    $foo = $2;
	    $Package = $3;
	    $foo1 = $4;
	    $Prefix = $5;
	    ($Module_cname = $Module) =~ s/\W/_/g;
	    ($Packid = $Package) =~ s/:/_/g;
	    $Packprefix = $Package;
	    $Packprefix .= "::" if defined $Packprefix && $Packprefix ne "";
	    while (<F>) {
		chop;
		next if /^#/ &&
		    !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
		last if /^\S/;
	    }
	    push(@line, $_) if $_ ne "";
	}
	else {
	    push(@line, $lastline);
	}
	$lastline = "";
	while (<F>) {
	    next if /^#/ &&
		!/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
	    chop;
	    if (/^\S/ && @line && $line[-1] eq "") {
		$lastline = $_;
		last;
	    }
	    else {
		push(@line, $_);
	    }
	}
	pop(@line) while @line && $line[-1] =~ /^\s*$/;
    }
    $PPCODE = grep(/PPCODE:/, @line);
    scalar @line;
}

while (&fetch_para) {
    # initialize info arrays
    undef(%args_match);
    undef(%var_types);
    undef(%var_addr);
    undef(%defaults);
    undef($class);
    undef($static);
    undef($elipsis);

    # extract return type, function name and arguments
    $ret_type = shift(@line);
    if ($ret_type =~ /^BOOT:/) {
        push (@BootCode, @line, "", "") ;
        next ;
    }
    if ($ret_type =~ /^static\s+(.*)$/) {
	    $static = 1;
	    $ret_type = $1;
    }
    $func_header = shift(@line);
    ($func_name, $orig_args) =  $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
    if ($func_name =~ /(.*)::(.*)/) {
	    $class = $1;
	    $func_name = $2;
    }
    ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
    push(@Func_name, "${Packid}_$func_name");
    push(@Func_pname, $pname);
    @args = split(/\s*,\s*/, $orig_args);
    if (defined($class)) {
	if (defined($static)) {
	    unshift(@args, "CLASS");
	    $orig_args = "CLASS, $orig_args";
	    $orig_args =~ s/^CLASS, $/CLASS/;
	}
	else {
	    unshift(@args, "THIS");
	    $orig_args = "THIS, $orig_args";
	    $orig_args =~ s/^THIS, $/THIS/;
	}
    }
    $orig_args =~ s/"/\\"/g;
    $min_args = $num_args = @args;
    foreach $i (0..$num_args-1) {
	    if ($args[$i] =~ s/\.\.\.//) {
		    $elipsis = 1;
		    $min_args--;
		    if ($args[i] eq '' && $i == $num_args - 1) {
			pop(@args);
			last;
		    }
	    }
	    if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
		    $min_args--;
		    $args[$i] = $1;
		    $defaults{$args[$i]} = $2;
		    $defaults{$args[$i]} =~ s/"/\\"/g;
	    }
    }
    if (defined($class)) {
	    $func_args = join(", ", @args[1..$#args]);
    } else {
	    $func_args = join(", ", @args);
    }
    @args_match{@args} = 1..@args;

    # print function header
    print Q<<"EOF";
#XS(XS_${Packid}_$func_name)
#[[
#    dXSARGS;
EOF
    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 $except;
#    char errbuf[1024];
#    *errbuf = '\0';
EOF

    print Q<<"EOF";
#    if ($cond) {
#	croak("Usage: $pname($orig_args)");
#    }
EOF

    print Q<<"EOF" if $PPCODE;
#    SP -= items;
EOF

    # Now do a block of some sort.

    $condnum = 0;
    if (!@line) {
	@line = "CLEANUP:";
    }
    while (@line) {
	if ($_[0] =~ s/^\s*CASE\s*:\s*//) {
	    $cond = shift(@line);
	    if ($condnum == 0) {
		print "    if ($cond)\n";
	    }
	    elsif ($cond ne '') {
		print "    else if ($cond)\n";
	    }
	    else {
		print "    else\n";
	    }
	    $condnum++;
	}

	if ($except) {
	    print Q<<"EOF";
#    TRY [[
EOF
	}
	else {
	    print Q<<"EOF";
#    [[
EOF
	}

	# do initialization of input variables
	$thisdone = 0;
	$retvaldone = 0;
	$deferred = "";
	while (@line) {
		$_ = shift(@line);
		last if /^\s*NOT_IMPLEMENTED_YET/;
		last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/;
		# Catch common error. Much more error checking required here.
		blurt("Error: no tab in $pname argument declaration '$_'\n")
			unless (m/\S+\s*\t\s*\S+/);
		($var_type, $var_name, $var_init) =
		    /\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/;
		if ($var_name =~ /^&/) {
			$var_name =~ s/^&//;
			$var_addr{$var_name} = 1;
		}
		$thisdone |= $var_name eq "THIS";
		$retvaldone |= $var_name eq "RETVAL";
		$var_types{$var_name} = $var_type;
		print "\t" . &map_type($var_type);
		$var_num = $args_match{$var_name};
		if ($var_addr{$var_name}) {
			$func_args =~ s/\b($var_name)\b/&\1/;
		}
		if ($var_init !~ /^=\s*NO_INIT\s*$/) {
			if ($var_init !~ /^\s*$/) {
				&output_init($var_type, $var_num,
				    "$var_name $var_init");
			} elsif ($var_num) {
				# generate initialization code
				&generate_init($var_type, $var_num, $var_name);
			} else {
				print ";\n";
			}
		} else {
			print "\t$var_name;\n";
		}
	}
	if (!$thisdone && defined($class)) {
	    if (defined($static)) {
		print "\tchar *";
		$var_types{"CLASS"} = "char *";
		&generate_init("char *", 1, "CLASS");
	    }
	    else {
		print "\t$class *";
		$var_types{"THIS"} = "$class *";
		&generate_init("$class *", 1, "THIS");
	    }
	}

	# do code
	if (/^\s*NOT_IMPLEMENTED_YET/) {
		print "\ncroak(\"$pname: not implemented yet\");\n";
	} else {
		if ($ret_type ne "void") {
			print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
				if !$retvaldone;
			$args_match{"RETVAL"} = 0;
			$var_types{"RETVAL"} = $ret_type;
		}
		if (/^\s*PPCODE:/) {
			print $deferred;
			while (@line) {
				$_ = shift(@line);
				die "PPCODE must be last thing"
				    if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
				print "$_\n";
			}
			print "\tPUTBACK;\n\treturn;\n";
		} elsif (/^\s*CODE:/) {
			print $deferred;
			while (@line) {
				$_ = shift(@line);
				last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
				print "$_\n";
			}
		} elsif ($func_name eq "DESTROY") {
			print $deferred;
			print "\n\t";
			print "delete THIS;\n"
		} else {
			print $deferred;
			print "\n\t";
			if ($ret_type ne "void") {
				print "RETVAL = ";
			}
			if (defined($static)) {
			    if ($func_name =~ /^new/) {
				$func_name = "$class";
			    }
			    else {
				print "$class::";
			    }
			} elsif (defined($class)) {
				print "THIS->";
			}
			if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
				$func_name = $2;
			}
			print "$func_name($func_args);\n";
			&generate_output($ret_type, 0, "RETVAL")
			    unless $ret_type eq "void";
		}
	}

	# do output variables
	if (/^\s*OUTPUT\s*:/) {
		while (@line) {
			$_ = shift(@line);
			last if /^\s*CLEANUP\s*:/;
			s/^\s+//;
			($outarg, $outcode) = split(/\t+/);
			if ($outcode) {
			    print "\t$outcode\n";
			} else {
				die "$outarg not an argument"
				    unless defined($args_match{$outarg});
				$var_num = $args_match{$outarg};
				&generate_output($var_types{$outarg}, $var_num,
				    $outarg); 
			}
		}
	}
	# do cleanup
	if (/^\s*CLEANUP\s*:/) {
	    while (@line) {
		    $_ = shift(@line);
		    last if /^\s*CASE\s*:/;
		    print "$_\n";
	    }
	}
	# print function trailer
	if ($except) {
	    print Q<<EOF;
#    ]]
#    BEGHANDLERS
#    CATCHALL
#	sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
#    ENDHANDLERS
EOF
	}
	else {
	    print Q<<EOF;
#    ]]
EOF
	}
	if (/^\s*CASE\s*:/) {
	    unshift(@line, $_);
	}
    }

    print Q<<EOF if $except;
#    if (errbuf[0])
#	croak(errbuf);
EOF

    print Q<<EOF unless $PPCODE;
#    XSRETURN(1);
EOF

    print Q<<EOF;
#]]
#
EOF
}

# print initialization routine
print qq/extern "C"\n/ if $cplusplus;
print Q<<"EOF";
#XS(boot_$Module_cname)
#[[
#    dXSARGS;
#    char* file = __FILE__;
#
EOF

for (@Func_name) {
    $pname = shift(@Func_pname);
    print "    newXS(\"$pname\", XS_$_, file);\n";
}

if (@BootCode)
{
    print "\n    /* Initialisation Section */\n\n" ;
    print grep (s/$/\n/, @BootCode) ;
    print "    /* End of Initialisation Section */\n\n" ;
}

print "    ST(0) = &sv_yes;\n";
print "    XSRETURN(1);\n";
print "}\n";

sub output_init {
    local($type, $num, $init) = @_;
    local($arg) = "ST(" . ($num - 1) . ")";

    eval qq/print " $init\\\n"/;
}

sub blurt { warn @_; $errors++ }

sub generate_init {
    local($type, $num, $var) = @_;
    local($arg) = "ST(" . ($num - 1) . ")";
    local($argoff) = $num - 1;
    local($ntype);
    local($tk);

    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$//;
    $tk = $type_kind{$type};
    $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
    $type =~ s/:/_/g;
    $expr = $input_expr{$tk};
    if ($expr =~ /DO_ARRAY_ELEM/) {
	$subexpr = $input_expr{$type_kind{$subtype}};
	$subexpr =~ s/ntype/subtype/g;
	$subexpr =~ s/\$arg/ST(ix_$var)/g;
	$subexpr =~ s/\n\t/\n\t\t/g;
	$subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
	$subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
	$expr =~ s/DO_ARRAY_ELEM/$subexpr/;
    }
    if (defined($defaults{$var})) {
	    $expr =~ s/(\t+)/$1    /g;
	    $expr =~ s/        /\t/g;
	    eval qq/print "\\t$var;\\n"/;
	    $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
    } elsif ($expr !~ /^\t\$var =/) {
	    eval qq/print "\\t$var;\\n"/;
	    $deferred .= eval qq/"\\n$expr;\\n"/;
    } else {
	    eval qq/print "$expr;\\n"/;
    }
}

sub generate_output {
    local($type, $num, $var) = @_;
    local($arg) = "ST(" . ($num - ($num != 0)) . ")";
    local($argoff) = $num - 1;
    local($ntype);

    if ($type =~ /^array\(([^,]*),(.*)\)/) {
	    print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
    } else {
	    blurt("$type not in typemap"), return
		unless defined($type_kind{$type});
	    ($ntype = $type) =~ s/\s*\*/Ptr/g;
	    $ntype =~ s/\(\)//g;
	    $subtype = $ntype;
	    $subtype =~ s/Ptr$//;
	    $subtype =~ s/Array$//;
	    $expr = $output_expr{$type_kind{$type}};
	    if ($expr =~ /DO_ARRAY_ELEM/) {
		$subexpr = $output_expr{$type_kind{$subtype}};
		$subexpr =~ s/ntype/subtype/g;
		$subexpr =~ s/\$arg/ST(ix_$var)/g;
		$subexpr =~ s/\$var/${var}[ix_$var]/g;
		$subexpr =~ s/\n\t/\n\t\t/g;
		$expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
		eval "print qq\a$expr\a";
	    }
	    elsif ($var eq 'RETVAL') {
		if ($expr =~ /^\t\$arg = /) {
		    eval "print qq\a$expr\a";
		    print "\tsv_2mortal(ST(0));\n";
		}
		else {
		    print "\tST(0) = sv_newmortal();\n";
		    eval "print qq\a$expr\a";
		}
	    }
	    elsif ($arg =~ /^ST\(\d+\)$/) {
		eval "print qq\a$expr\a";
	    }
	    elsif ($arg =~ /^ST\(\d+\)$/) {
		eval "print qq\a$expr\a";
	    }
	    elsif ($arg =~ /^ST\(\d+\)$/) {
		eval "print qq\a$expr\a";
	    }
    }
}

sub map_type {
    local($type) = @_;

    $type =~ s/:/_/g;
    if ($type =~ /^array\(([^,]*),(.*)\)/) {
	    return "$1 *";
    } else {
	    return $type;
    }
}

exit $errors;

##############################################################################

	# These next few lines are legal in both Perl and nroff.

.00 ;			# finish .ig
 
'di			\" finish diversion--previous line must be blank
.nr nl 0-1		\" fake up transition to first page again
.nr % 0			\" start at page 1
'; __END__ ############# From here on it's a standard manual page ############
.TH XSUBPP 1 "August 9, 1994"
.AT 3
.SH NAME
xsubpp \- compiler to convert Perl XS code into C code
.SH SYNOPSIS
.B xsubpp [-C++] [-except] [-typemap typemap] file.xs
.SH DESCRIPTION
.I xsubpp
will compile XS code into C code by embedding the constructs necessary to
let C functions manipulate Perl values and creates the glue necessary to let
Perl access those functions.  The compiler uses typemaps to determine how
to map C function parameters and variables to Perl values.
.PP
The compiler will search for typemap files called
.I typemap.
It will use the following search path to find default typemaps, with the
rightmost typemap taking precedence.
.br
.nf
	../../../typemap:../../typemap:../typemap:typemap
.fi
.SH OPTIONS
.TP
.B \-C++
.br
Adds ``extern "C"'' to the C code.
.TP
.B \-except
Adds exception handling stubs to the C code.
.TP
.B \-typemap typemap
Indicates that a user-supplied typemap should take precedence over the
default typemaps.  This option may be used multiple times, with the last
typemap having the highest precedence.
.SH ENVIRONMENT
No environment variables are used.
.SH AUTHOR
Larry Wall
.SH "SEE ALSO"
perl(1)
.ex
Commit	Line	Data
2304df62	1	#!./miniperl
a0d0e21e	2	'di ';
	3	'ds 00 \"';
	4	'ig 00 ';
93a17b20	5	# $Header$
93a17b20	6
a0d0e21e	7	$usage = "Usage: xsubpp [-C++] [-except] [-typemap typemap] file.xs\n";
93a17b20	8
8990e307	9	SWITCH: while ($ARGV[0] =~ s/^-//) {
93a17b20	10	$flag = shift @ARGV;
8990e307	11	$spat = shift, next SWITCH if $flag eq 's';
	12	$cplusplus = 1, next SWITCH if $flag eq 'C++';
	13	$except = 1, next SWITCH if $flag eq 'except';
	14	push(@tm,shift), next SWITCH if $flag eq 'typemap';
93a17b20	15	die $usage;
93a17b20	16	}
8990e307	17	@ARGV == 1 or die $usage;
	18	chop($pwd = `pwd`);
	19	($dir, $filename) = @ARGV[0] =~ m#(.)/(.)#
a0d0e21e	20	or ($dir, $filename) = @ARGV[0] =~ m#(.[>\]])(.)#
8990e307	21	or ($dir, $filename) = ('.', $ARGV[0]);
8990e307	22	chdir($dir);
93a17b20	23
93a17b20	24	$typemap = shift @ARGV;
8990e307	25	foreach $typemap (@tm) {
8990e307	26	die "Can't find $typemap in $pwd\n" unless -r $typemap;
93a17b20	27	}
8990e307	28	unshift @tm, qw(../../../typemap ../../typemap ../typemap typemap);
	29	foreach $typemap (@tm) {
	30	open(TYPEMAP, $typemap) \|\| next;
	31	$mode = Typemap;
	32	$current = \$junk;
	33	while (<TYPEMAP>) {
	34	next if /^#/;
	35	if (/^INPUT\s*$/) { $mode = Input, next }
	36	if (/^OUTPUT\s*$/) { $mode = Output, next }
	37	if (/^TYPEMAP\s*$/) { $mode = Typemap, next }
	38	if ($mode eq Typemap) {
	39	chop;
	40	($typename, $kind) = split(/\t+/, $_, 2);
	41	$type_kind{$typename} = $kind if $kind ne '';
463ee0b2	42	}
8990e307	43	elsif ($mode eq Input) {
	44	if (/^\s/) {
	45	$$current .= $_;
	46	}
	47	else {
	48	s/\s*$//;
a0d0e21e	49	$input_expr{$_} = '';
8990e307	50	$current = \$input_expr{$_};
8990e307	51	}
93a17b20	52	}
8990e307	53	else {
	54	if (/^\s/) {
	55	$$current .= $_;
	56	}
	57	else {
	58	s/\s*$//;
a0d0e21e	59	$output_expr{$_} = '';
8990e307	60	$current = \$output_expr{$_};
8990e307	61	}
93a17b20	62	}
8990e307	63	}
	64	close(TYPEMAP);
	65	}
93a17b20	66
8990e307	67	foreach $key (keys %input_expr) {
	68	$input_expr{$key} =~ s/\n+$//;
	69	}
93a17b20	70
8990e307	71	sub Q {
	72	local $text = shift;
	73	$text =~ tr/#//d;
2304df62	74	$text =~ s/\[\[/{/g;
2304df62	75	$text =~ s/\]\]/}/g;
8990e307	76	$text;
93a17b20	77	}
93a17b20	78
8990e307	79	open(F, $filename) \|\| die "cannot open $filename\n";
8990e307	80
93a17b20	81	while (<F>) {
a0d0e21e	82	last if ($Module, $foo, $Package, $foo1, $Prefix) =
	83	/^MODULE\s=\s([\w:]+)(\s+PACKAGE\s=\s([\w:]+))?(\s+PREFIX\s=\s(\S+))?\s*$/;
	84	print $_;
93a17b20	85	}
2304df62	86	exit 0 if $_ eq "";
2304df62	87	$lastline = $_;
93a17b20	88
2304df62	89	sub fetch_para {
	90	# parse paragraph
	91	@line = ();
	92	if ($lastline ne "") {
	93	if ($lastline =~
a0d0e21e	94	/^MODULE\s=\s([\w:]+)(\s+PACKAGE\s=\s([\w:]+))?(\s+PREFIX\s=\s(\S+))?\s*$/) {
2304df62	95	$Module = $1;
	96	$foo = $2;
	97	$Package = $3;
	98	$foo1 = $4;
	99	$Prefix = $5;
a0d0e21e	100	($Module_cname = $Module) =~ s/\W/_/g;
2304df62	101	($Packid = $Package) =~ s/:/_/g;
	102	$Packprefix = $Package;
	103	$Packprefix .= "::" if defined $Packprefix && $Packprefix ne "";
	104	while (<F>) {
	105	chop;
a0d0e21e	106	next if /^#/ &&
a0d0e21e	107	!/^#[ \t]*(if\|ifdef\|ifndef\|else\|elif\|endif\|define\|undef)\b/;
2304df62	108	last if /^\S/;
	109	}
	110	push(@line, $_) if $_ ne "";
93a17b20	111	}
2304df62	112	else {
2304df62	113	push(@line, $lastline);
93a17b20	114	}
2304df62	115	$lastline = "";
2304df62	116	while (<F>) {
a0d0e21e	117	next if /^#/ &&
a0d0e21e	118	!/^#[ \t]*(if\|ifdef\|ifndef\|else\|elif\|endif\|define\|undef)\b/;
2304df62	119	chop;
	120	if (/^\S/ && @line && $line[-1] eq "") {
	121	$lastline = $_;
	122	last;
	123	}
	124	else {
	125	push(@line, $_);
	126	}
93a17b20	127	}
a0d0e21e	128	pop(@line) while @line && $line[-1] =~ /^\s*$/;
2304df62	129	}
a0d0e21e	130	$PPCODE = grep(/PPCODE:/, @line);
2304df62	131	scalar @line;
2304df62	132	}
93a17b20	133
2304df62	134	while (&fetch_para) {
	135	# initialize info arrays
	136	undef(%args_match);
	137	undef(%var_types);
	138	undef(%var_addr);
	139	undef(%defaults);
	140	undef($class);
	141	undef($static);
	142	undef($elipsis);
	143
	144	# extract return type, function name and arguments
	145	$ret_type = shift(@line);
a0d0e21e	146	if ($ret_type =~ /^BOOT:/) {
	147	push (@BootCode, @line, "", "") ;
	148	next ;
	149	}
2304df62	150	if ($ret_type =~ /^static\s+(.*)$/) {
	151	$static = 1;
	152	$ret_type = $1;
	153	}
	154	$func_header = shift(@line);
	155	($func_name, $orig_args) = $func_header =~ /^([\w:]+)\s\((.)\)$/;
	156	if ($func_name =~ /(.)::(.)/) {
	157	$class = $1;
	158	$func_name = $2;
	159	}
	160	($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
	161	push(@Func_name, "${Packid}_$func_name");
	162	push(@Func_pname, $pname);
	163	@args = split(/\s,\s/, $orig_args);
a0d0e21e	164	if (defined($class)) {
	165	if (defined($static)) {
	166	unshift(@args, "CLASS");
	167	$orig_args = "CLASS, $orig_args";
	168	$orig_args =~ s/^CLASS, $/CLASS/;
	169	}
	170	else {
2304df62	171	unshift(@args, "THIS");
	172	$orig_args = "THIS, $orig_args";
	173	$orig_args =~ s/^THIS, $/THIS/;
a0d0e21e	174	}
2304df62	175	}
	176	$orig_args =~ s/"/\\"/g;
	177	$min_args = $num_args = @args;
	178	foreach $i (0..$num_args-1) {
	179	if ($args[$i] =~ s/\.\.\.//) {
	180	$elipsis = 1;
	181	$min_args--;
	182	if ($args[i] eq '' && $i == $num_args - 1) {
	183	pop(@args);
	184	last;
	185	}
	186	}
	187	if ($args[$i] =~ /([^=]\S)\s=\s(.)/) {
	188	$min_args--;
	189	$args[$i] = $1;
	190	$defaults{$args[$i]} = $2;
	191	$defaults{$args[$i]} =~ s/"/\\"/g;
	192	}
	193	}
a0d0e21e	194	if (defined($class)) {
2304df62	195	$func_args = join(", ", @args[1..$#args]);
	196	} else {
	197	$func_args = join(", ", @args);
	198	}
	199	@args_match{@args} = 1..@args;
	200
	201	# print function header
a0d0e21e	202	print Q<<"EOF";
a0d0e21e	203	#XS(XS_${Packid}_$func_name)
2304df62	204	#[[
a0d0e21e	205	# dXSARGS;
93a17b20	206	EOF
2304df62	207	if ($elipsis) {
	208	$cond = qq(items < $min_args);
	209	}
	210	elsif ($min_args == $num_args) {
	211	$cond = qq(items != $min_args);
	212	}
	213	else {
	214	$cond = qq(items < $min_args \|\| items > $num_args);
	215	}
8990e307	216
2304df62	217	print Q<<"EOF" if $except;
	218	# char errbuf[1024];
	219	# *errbuf = '\0';
	220	EOF
	221
	222	print Q<<"EOF";
8990e307	223	# if ($cond) {
	224	# croak("Usage: $pname($orig_args)");
	225	# }
93a17b20	226	EOF
93a17b20	227
a0d0e21e	228	print Q<<"EOF" if $PPCODE;
	229	# SP -= items;
	230	EOF
	231
2304df62	232	# Now do a block of some sort.
93a17b20	233
2304df62	234	$condnum = 0;
	235	if (!@line) {
	236	@line = "CLEANUP:";
	237	}
	238	while (@line) {
93a17b20	239	if ($_[0] =~ s/^\sCASE\s:\s*//) {
2304df62	240	$cond = shift(@line);
	241	if ($condnum == 0) {
	242	print " if ($cond)\n";
	243	}
	244	elsif ($cond ne '') {
	245	print " else if ($cond)\n";
	246	}
	247	else {
	248	print " else\n";
	249	}
	250	$condnum++;
93a17b20	251	}
93a17b20	252
8990e307	253	if ($except) {
8990e307	254	print Q<<"EOF";
2304df62	255	# TRY [[
93a17b20	256	EOF
8990e307	257	}
	258	else {
	259	print Q<<"EOF";
2304df62	260	# [[
93a17b20	261	EOF
8990e307	262	}
93a17b20	263
	264	# do initialization of input variables
	265	$thisdone = 0;
	266	$retvaldone = 0;
463ee0b2	267	$deferred = "";
2304df62	268	while (@line) {
2304df62	269	$_ = shift(@line);
93a17b20	270	last if /^\s*NOT_IMPLEMENTED_YET/;
2304df62	271	last if /^\s(PPCODE\|CODE\|OUTPUT\|CLEANUP\|CASE)\s:/;
a0d0e21e	272	# Catch common error. Much more error checking required here.
	273	blurt("Error: no tab in $pname argument declaration '$_'\n")
	274	unless (m/\S+\s\t\s\S+/);
93a17b20	275	($var_type, $var_name, $var_init) =
	276	/\s([^\t]+)\s([^\s=]+)\s(=.)?/;
	277	if ($var_name =~ /^&/) {
	278	$var_name =~ s/^&//;
	279	$var_addr{$var_name} = 1;
	280	}
	281	$thisdone \|= $var_name eq "THIS";
	282	$retvaldone \|= $var_name eq "RETVAL";
	283	$var_types{$var_name} = $var_type;
	284	print "\t" . &map_type($var_type);
	285	$var_num = $args_match{$var_name};
	286	if ($var_addr{$var_name}) {
	287	$func_args =~ s/\b($var_name)\b/&\1/;
	288	}
	289	if ($var_init !~ /^=\sNO_INIT\s$/) {
	290	if ($var_init !~ /^\s*$/) {
	291	&output_init($var_type, $var_num,
	292	"$var_name $var_init");
	293	} elsif ($var_num) {
	294	# generate initialization code
	295	&generate_init($var_type, $var_num, $var_name);
	296	} else {
	297	print ";\n";
	298	}
	299	} else {
	300	print "\t$var_name;\n";
	301	}
	302	}
a0d0e21e	303	if (!$thisdone && defined($class)) {
	304	if (defined($static)) {
	305	print "\tchar *";
	306	$var_types{"CLASS"} = "char *";
	307	&generate_init("char *", 1, "CLASS");
	308	}
	309	else {
93a17b20	310	print "\t$class *";
	311	$var_types{"THIS"} = "$class *";
	312	&generate_init("$class *", 1, "THIS");
a0d0e21e	313	}
93a17b20	314	}
	315
	316	# do code
	317	if (/^\s*NOT_IMPLEMENTED_YET/) {
463ee0b2	318	print "\ncroak(\"$pname: not implemented yet\");\n";
93a17b20	319	} else {
	320	if ($ret_type ne "void") {
	321	print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
	322	if !$retvaldone;
	323	$args_match{"RETVAL"} = 0;
	324	$var_types{"RETVAL"} = $ret_type;
	325	}
2304df62	326	if (/^\s*PPCODE:/) {
2304df62	327	print $deferred;
	328	while (@line) {
	329	$_ = shift(@line);
a0d0e21e	330	die "PPCODE must be last thing"
a0d0e21e	331	if /^\s(OUTPUT\|CLEANUP\|CASE)\s:/;
2304df62	332	print "$_\n";
2304df62	333	}
a0d0e21e	334	print "\tPUTBACK;\n\treturn;\n";
2304df62	335	} elsif (/^\s*CODE:/) {
	336	print $deferred;
	337	while (@line) {
	338	$_ = shift(@line);
93a17b20	339	last if /^\s(OUTPUT\|CLEANUP\|CASE)\s:/;
	340	print "$_\n";
	341	}
a0d0e21e	342	} elsif ($func_name eq "DESTROY") {
	343	print $deferred;
	344	print "\n\t";
	345	print "delete THIS;\n"
93a17b20	346	} else {
2304df62	347	print $deferred;
93a17b20	348	print "\n\t";
93a17b20	349	if ($ret_type ne "void") {
463ee0b2	350	print "RETVAL = ";
93a17b20	351	}
93a17b20	352	if (defined($static)) {
a0d0e21e	353	if ($func_name =~ /^new/) {
	354	$func_name = "$class";
	355	}
	356	else {
93a17b20	357	print "$class::";
a0d0e21e	358	}
93a17b20	359	} elsif (defined($class)) {
	360	print "THIS->";
	361	}
	362	if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
	363	$func_name = $2;
	364	}
	365	print "$func_name($func_args);\n";
	366	&generate_output($ret_type, 0, "RETVAL")
	367	unless $ret_type eq "void";
	368	}
	369	}
	370
	371	# do output variables
	372	if (/^\sOUTPUT\s:/) {
2304df62	373	while (@line) {
2304df62	374	$_ = shift(@line);
93a17b20	375	last if /^\sCLEANUP\s:/;
	376	s/^\s+//;
	377	($outarg, $outcode) = split(/\t+/);
	378	if ($outcode) {
a0d0e21e	379	print "\t$outcode\n";
93a17b20	380	} else {
	381	die "$outarg not an argument"
	382	unless defined($args_match{$outarg});
	383	$var_num = $args_match{$outarg};
	384	&generate_output($var_types{$outarg}, $var_num,
	385	$outarg);
	386	}
	387	}
	388	}
	389	# do cleanup
	390	if (/^\sCLEANUP\s:/) {
2304df62	391	while (@line) {
2304df62	392	$_ = shift(@line);
93a17b20	393	last if /^\sCASE\s:/;
	394	print "$_\n";
	395	}
	396	}
	397	# print function trailer
8990e307	398	if ($except) {
8990e307	399	print Q<<EOF;
2304df62	400	# ]]
8990e307	401	# BEGHANDLERS
	402	# CATCHALL
	403	# sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
	404	# ENDHANDLERS
93a17b20	405	EOF
8990e307	406	}
	407	else {
	408	print Q<<EOF;
2304df62	409	# ]]
93a17b20	410	EOF
8990e307	411	}
93a17b20	412	if (/^\sCASE\s:/) {
8990e307	413	unshift(@line, $_);
93a17b20	414	}
2304df62	415	}
a0d0e21e	416
2304df62	417	print Q<<EOF if $except;
	418	# if (errbuf[0])
	419	# croak(errbuf);
	420	EOF
a0d0e21e	421
	422	print Q<<EOF unless $PPCODE;
	423	# XSRETURN(1);
	424	EOF
	425
2304df62	426	print Q<<EOF;
2304df62	427	#]]
8990e307	428	#
93a17b20	429	EOF
	430	}
	431
	432	# print initialization routine
8990e307	433	print qq/extern "C"\n/ if $cplusplus;
8990e307	434	print Q<<"EOF";
a0d0e21e	435	#XS(boot_$Module_cname)
2304df62	436	#[[
a0d0e21e	437	# dXSARGS;
8990e307	438	# char* file = __FILE__;
8990e307	439	#
93a17b20	440	EOF
	441
	442	for (@Func_name) {
2304df62	443	$pname = shift(@Func_pname);
a0d0e21e	444	print " newXS(\"$pname\", XS_$_, file);\n";
	445	}
	446
	447	if (@BootCode)
	448	{
	449	print "\n /* Initialisation Section */\n\n" ;
	450	print grep (s/$/\n/, @BootCode) ;
	451	print " /* End of Initialisation Section */\n\n" ;
93a17b20	452	}
a0d0e21e	453
	454	print " ST(0) = &sv_yes;\n";
	455	print " XSRETURN(1);\n";
93a17b20	456	print "}\n";
	457
	458	sub output_init {
2304df62	459	local($type, $num, $init) = @_;
a0d0e21e	460	local($arg) = "ST(" . ($num - 1) . ")";
93a17b20	461
2304df62	462	eval qq/print " $init\\\n"/;
93a17b20	463	}
93a17b20	464
8990e307	465	sub blurt { warn @_; $errors++ }
8990e307	466
93a17b20	467	sub generate_init {
2304df62	468	local($type, $num, $var) = @_;
a0d0e21e	469	local($arg) = "ST(" . ($num - 1) . ")";
2304df62	470	local($argoff) = $num - 1;
	471	local($ntype);
	472	local($tk);
93a17b20	473
2304df62	474	blurt("$type not in typemap"), return unless defined($type_kind{$type});
	475	($ntype = $type) =~ s/\s\/Ptr/g;
	476	$subtype = $ntype;
	477	$subtype =~ s/Ptr$//;
	478	$subtype =~ s/Array$//;
	479	$tk = $type_kind{$type};
	480	$tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
	481	$type =~ s/:/_/g;
	482	$expr = $input_expr{$tk};
	483	if ($expr =~ /DO_ARRAY_ELEM/) {
	484	$subexpr = $input_expr{$type_kind{$subtype}};
	485	$subexpr =~ s/ntype/subtype/g;
	486	$subexpr =~ s/\$arg/ST(ix_$var)/g;
	487	$subexpr =~ s/\n\t/\n\t\t/g;
	488	$subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
a0d0e21e	489	$subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
2304df62	490	$expr =~ s/DO_ARRAY_ELEM/$subexpr/;
	491	}
	492	if (defined($defaults{$var})) {
	493	$expr =~ s/(\t+)/$1 /g;
	494	$expr =~ s/ /\t/g;
	495	eval qq/print "\\t$var;\\n"/;
	496	$deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
	497	} elsif ($expr !~ /^\t\$var =/) {
	498	eval qq/print "\\t$var;\\n"/;
	499	$deferred .= eval qq/"\\n$expr;\\n"/;
	500	} else {
	501	eval qq/print "$expr;\\n"/;
	502	}
93a17b20	503	}
	504
	505	sub generate_output {
2304df62	506	local($type, $num, $var) = @_;
a0d0e21e	507	local($arg) = "ST(" . ($num - ($num != 0)) . ")";
2304df62	508	local($argoff) = $num - 1;
2304df62	509	local($ntype);
93a17b20	510
2304df62	511	if ($type =~ /^array\(([^,]),(.)\)/) {
	512	print "\tsv_setpvn($arg, (char )$var, $2 sizeof($1)), XFree((char *)$var);\n";
	513	} else {
	514	blurt("$type not in typemap"), return
	515	unless defined($type_kind{$type});
	516	($ntype = $type) =~ s/\s\/Ptr/g;
	517	$ntype =~ s/\(\)//g;
	518	$subtype = $ntype;
	519	$subtype =~ s/Ptr$//;
	520	$subtype =~ s/Array$//;
	521	$expr = $output_expr{$type_kind{$type}};
	522	if ($expr =~ /DO_ARRAY_ELEM/) {
	523	$subexpr = $output_expr{$type_kind{$subtype}};
	524	$subexpr =~ s/ntype/subtype/g;
	525	$subexpr =~ s/\$arg/ST(ix_$var)/g;
	526	$subexpr =~ s/\$var/${var}[ix_$var]/g;
	527	$subexpr =~ s/\n\t/\n\t\t/g;
	528	$expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
a0d0e21e	529	eval "print qq\a$expr\a";
2304df62	530	}
a0d0e21e	531	elsif ($var eq 'RETVAL') {
2304df62	532	if ($expr =~ /^\t\$arg = /) {
a0d0e21e	533	eval "print qq\a$expr\a";
2304df62	534	print "\tsv_2mortal(ST(0));\n";
93a17b20	535	}
2304df62	536	else {
8990e307	537	print "\tST(0) = sv_newmortal();\n";
a0d0e21e	538	eval "print qq\a$expr\a";
463ee0b2	539	}
2304df62	540	}
a0d0e21e	541	elsif ($arg =~ /^ST\(\d+\)$/) {
	542	eval "print qq\a$expr\a";
	543	}
	544	elsif ($arg =~ /^ST\(\d+\)$/) {
	545	eval "print qq\a$expr\a";
	546	}
	547	elsif ($arg =~ /^ST\(\d+\)$/) {
	548	eval "print qq\a$expr\a";
	549	}
2304df62	550	}
93a17b20	551	}
	552
	553	sub map_type {
2304df62	554	local($type) = @_;
93a17b20	555
2304df62	556	$type =~ s/:/_/g;
	557	if ($type =~ /^array\(([^,]),(.)\)/) {
	558	return "$1 *";
	559	} else {
	560	return $type;
	561	}
93a17b20	562	}
8990e307	563
8990e307	564	exit $errors;
a0d0e21e	565
	566	##############################################################################
	567
	568	# These next few lines are legal in both Perl and nroff.
	569
	570	.00 ; # finish .ig
	571
	572	'di \" finish diversion--previous line must be blank
	573	.nr nl 0-1 \" fake up transition to first page again
	574	.nr % 0 \" start at page 1
	575	'; __END__ ############# From here on it's a standard manual page ############
	576	.TH XSUBPP 1 "August 9, 1994"
	577	.AT 3
	578	.SH NAME
	579	xsubpp \- compiler to convert Perl XS code into C code
	580	.SH SYNOPSIS
	581	.B xsubpp [-C++] [-except] [-typemap typemap] file.xs
	582	.SH DESCRIPTION
	583	.I xsubpp
	584	will compile XS code into C code by embedding the constructs necessary to
	585	let C functions manipulate Perl values and creates the glue necessary to let
	586	Perl access those functions. The compiler uses typemaps to determine how
	587	to map C function parameters and variables to Perl values.
	588	.PP
	589	The compiler will search for typemap files called
	590	.I typemap.
	591	It will use the following search path to find default typemaps, with the
	592	rightmost typemap taking precedence.
	593	.br
	594	.nf
	595	../../../typemap:../../typemap:../typemap:typemap
	596	.fi
	597	.SH OPTIONS
	598	.TP
	599	.B \-C++
	600	.br
	601	Adds ``extern "C"'' to the C code.
	602	.TP
	603	.B \-except
	604	Adds exception handling stubs to the C code.
	605	.TP
	606	.B \-typemap typemap
	607	Indicates that a user-supplied typemap should take precedence over the
	608	default typemaps. This option may be used multiple times, with the last
	609	typemap having the highest precedence.
	610	.SH ENVIRONMENT
	611	No environment variables are used.
	612	.SH AUTHOR
	613	Larry Wall
	614	.SH "SEE ALSO"
	615	perl(1)
	616	.ex