path: root/ext/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