path: root/lib/ExtUtils/xsubpp

#!./miniperl

=head1 NAME

xsubpp - compiler to convert Perl XS code into C code

=head1 SYNOPSIS

B<xsubpp> [B<-C++>] [B<-except>] [B<-typemap typemap>] file.xs

=head1 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.

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.

	../../../typemap:../../typemap:../typemap:typemap

=head1 OPTIONS

=over 5

=item B<-C++>

Adds ``extern "C"'' to the C code.


=item B<-except>

Adds exception handling stubs to the C code.

=item 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.

=back

=head1 ENVIRONMENT

No environment variables are used.

=head1 AUTHOR

Larry Wall

=head1 MODIFICATION HISTORY

=head2 1.0

I<xsubpp> as released with Perl 5.000

=head2 1.1

I<xsubpp> as released with Perl 5.001

=head2 1.2 

Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 22 May 1995.

=over 5

=item 1.

Added I<xsubpp> version number for the first time. As previous releases
of I<xsubpp> did not have a formal version number, a numbering scheme
has been applied retrospectively.

=item 2.

If OUTPUT: is being used to specify output parameters and RETVAL is
also to be returned, it is now no longer necessary for the user to
ensure that RETVAL is specified last.

=item 3.

The I<xsubpp> version number, the .xs filename and a time stamp are
written to the generated .c file as a comment.

=item 4.

When I<xsubpp> is parsing the definition of both the input parameters
and the OUTPUT parameters, any duplicate definitions will be noted and
ignored.

=item 5.

I<xsubpp> is slightly more forgiving with extra whitespace.

=back

=head2 1.3 

Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 23 May 1995.

=over 5

=item 1.

More whitespace restrictions have been relaxed. In particular some
cases where a tab character was used to delimit fields has been
removed. In these cases any whitespace will now suffice.

The specific places where changes have been made are in the TYPEMAP
section of a typemap file and the input and OUTPUT: parameter
declarations sections in a .xs file.

=item 2.

More error checking added.

Before processing each typemap file I<xsubpp> now checks that it is a
text file. If not an warning will be displayed. In addition, a warning
will be displayed if it is not possible to open the typemap file.

In the TYPEMAP section of a typemap file, an error will be raised if
the line does not have 2 columns.

When parsing input parameter declarations check that there is at least
a type and name pair.

=back

=head2 1.4 

When parsing the OUTPUT arguments check that they are all present in
the corresponding input argument definitions.

=head1 SEE ALSO

perl(1)

=cut

# Global Constants
$XSUBPP_version = "1.4" ;

$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`);
# Check for error message from VMS
if ($pwd =~ /unrecognized command verb/) { $Is_VMS = 1; $pwd = $ENV{DEFAULT} }
($dir, $filename) = @ARGV[0] =~ m#(.*)/(.*)#
	or ($dir, $filename) = @ARGV[0] =~ m#(.*[>\]])(.*)#
	or ($dir, $filename) = ('.', $ARGV[0]);
chdir($dir);

sub TrimWhitespace
{
    $_[0] =~ s/^\s+|\s+$//go ;
}

sub TidyType
{
    local ($_) = @_ ;

    # rationalise any '*' by joining them into bunches and removing whitespace
    s#\s*(\*+)\s*#$1#g;

    # change multiple whitespace into a single space
    s/\s+/ /g ;
    
    # trim leading & trailing whitespace
    TrimWhitespace($_) ;

    $_ ;
}

$typemap = shift @ARGV;
foreach $typemap (@tm) {
    die "Can't find $typemap in $pwd\n" unless -r $typemap;
}
unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
                ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
                ../typemap typemap);
foreach $typemap (@tm) {
    next unless -e $typemap ;
    # skip directories, binary files etc.
    warn("Warning: ignoring non-text typemap file '$typemap'\n"), next 
	unless -T $typemap ;
    open(TYPEMAP, $typemap) 
	or warn ("Warning: could not open typemap file '$typemap': $!\n"), 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;
	    my $line = $_ ;
            TrimWhitespace($_) ;
	    # skip blank lines and comment lines
	    next if /^$/ or /^#/ ;
	    my @words = split (' ') ;
	    blurt("Error: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 columns\n"), next 
		unless @words >= 2 ;
	    my $kind = pop @words ;
            TrimWhitespace($kind) ;
	    $type_kind{TidyType("@words")} = $kind ;
	}
	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;
}

# Identify the version of xsubpp used
$TimeStamp = localtime ;
print <<EOM ;
/* 
 * This file was generated automatically by xsubpp version $XSUBPP_version
 * from $filename on $TimeStamp
 *
 */
 
EOM
 

open(F, $filename) or 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);
    undef($wantRETVAL) ;
    undef(%arg_list) ;

    # extract return type, function name and arguments
    $ret_type = TidyType(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*:/;

                TrimWhitespace($_) ;
                # skip blank lines 
                next if /^$/ ;
		my $line = $_ ;
	  	# check for optional initialisation code
		my $var_init = $1 if s/\s*(=.*)$// ;

                my @words = split (' ') ;
                blurt("Error: invalid argument declaration '$line'"), next
                    unless @words >= 2 ;
                my $var_name = pop @words ;
		my $var_type = "@words" ;

		# catch C style argument declaration (this could be made alowable syntax)
		warn("Warning: ignored semicolon in $pname argument declaration '$_'\n")
			if ($var_name =~ s/;//g); # eg SV *<tab>name;
		# catch many errors similar to: SV<tab>* name
		blurt("Error: invalid $pname argument name '$var_name' (type '$var_type')\n")
			unless ($var_name =~ m/^&?\w+$/);
		if ($var_name =~ /^&/) {
			$var_name =~ s/^&//;
			$var_addr{$var_name} = 1;
		}

	        # Check for duplicate definitions
	        blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
		    if $arg_list{$var_name} ++  ;

		$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";
			$wantRETVAL = 1 
	    		    unless $ret_type eq "void";
		}
	}

	# do output variables
	if (/^\s*OUTPUT\s*:/) {
		my $gotRETVAL ;
		my %outargs ;
		while (@line) {
			$_ = shift(@line);
			last if /^\s*CLEANUP\s*:/;
			TrimWhitespace($_) ;
			next if /^$/ ;
			my ($outarg, $outcode) = /^(\S+)\s*(.*)/ ;
			if (!$gotRETVAL and $outarg eq 'RETVAL') {
			    # deal with RETVAL last
			    push(@line, $_) ;
			    $gotRETVAL = 1 ;
			    undef ($wantRETVAL) ;
			    next ;
			}
			blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
			    if $outargs{$outarg} ++ ;
			blurt ("Error: OUTPUT $outarg not an argument"), next
			    unless defined($args_match{$outarg});
			blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
			    unless defined $var_types{$outarg} ;
			if ($outcode) {
			    print "\t$outcode\n";
			} else {
				$var_num = $args_match{$outarg};
				&generate_output($var_types{$outarg}, $var_num,
				    $outarg); 
			}
		}
	}

	# all OUTPUT done, so now push the return value on the stack
	&generate_output($ret_type, 0, "RETVAL")
	     if $wantRETVAL ;

	# 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);

    $type = TidyType($type) ;
    blurt("Error: '$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);

    $type = TidyType($type) ;
    if ($type =~ /^array\(([^,]*),(.*)\)/) {
	    print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
    } else {
	    blurt("Error: '$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;
    }
}

# If this is VMS, the exit status has meaning to the shell, so we
# use a predictable value (SS$_Abort) rather than an arbitrary
# number.
exit $Is_VMS ? 44 : $errors;