xsubpp

UNIX下perl实现代码

#!./miniperl

=head1 NAME

xsubpp - compiler to convert Perl XS code into C code

=head1 SYNOPSIS

B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] ... file.xs

=head1 DESCRIPTION

This compiler is typically run by the makefiles created by L<ExtUtils::MakeMaker>.

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

Note that the C<XSOPT> MakeMaker option may be used to add these options to
any makefiles generated by MakeMaker.

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

=item B<-v>

Prints the I<xsubpp> version number to standard output, then exits.

=item B<-prototypes>

By default I<xsubpp> will not automatically generate prototype code for
all xsubs. This flag will enable prototypes.

=item B<-noversioncheck>

Disables the run time test that determines if the object file (derived
from the C<.xs> file) and the C<.pm> files have the same version
number.

=item B<-nolinenumbers>

Prevents the inclusion of `#line' directives in the output.

=item B<-nooptimize>

Disables certain optimizations.  The only optimization that is currently
affected is the use of I<target>s by the output C code (see L<perlguts>).
This may significantly slow down the generated code, but this is the way
B<xsubpp> of 5.005 and earlier operated.

=item B<-noinout>

Disable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST> declarations.

=item B<-noargtypes>

Disable recognition of ANSI-like descriptions of function signature.

=back

=head1 ENVIRONMENT

No environment variables are used.

=head1 AUTHOR

Larry Wall

=head1 MODIFICATION HISTORY

See the file F<changes.pod>.

=head1 SEE ALSO

perl(1), perlxs(1), perlxstut(1)

=cut

require 5.002;
use Cwd;
use vars '$cplusplus';
use vars '%v';

use Config;

sub Q ;

# Global Constants

$XSUBPP_version = "1.9508";

my ($Is_VMS, $SymSet);
if ($^O eq 'VMS') {
    $Is_VMS = 1;
    # Establish set of global symbols with max length 28, since xsubpp
    # will later add the 'XS_' prefix.
    require ExtUtils::XSSymSet;
    $SymSet = new ExtUtils::XSSymSet 28;
}

$FH = 'File0000' ;

$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-s pattern] [-typemap typemap]... file.xs\n";

$proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
# mjn
$OBJ   = 1 if $Config{'ccflags'} =~ /PERL_OBJECT/i;

$except = "";
$WantPrototypes = -1 ;
$WantVersionChk = 1 ;
$ProtoUsed = 0 ;
$WantLineNumbers = 1 ;
$WantOptimize = 1 ;

my $process_inout = 1;
my $process_argtypes = 1;

SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
    $flag = shift @ARGV;
    $flag =~ s/^-// ;
    $spat = quotemeta shift,	next SWITCH	if $flag eq 's';
    $cplusplus = 1,	next SWITCH	if $flag eq 'C++';
    $WantPrototypes = 0, next SWITCH	if $flag eq 'noprototypes';
    $WantPrototypes = 1, next SWITCH	if $flag eq 'prototypes';
    $WantVersionChk = 0, next SWITCH	if $flag eq 'noversioncheck';
    $WantVersionChk = 1, next SWITCH	if $flag eq 'versioncheck';
    # XXX left this in for compat
    $WantCAPI = 1, next SWITCH    if $flag eq 'object_capi';
    $except = " TRY",	next SWITCH	if $flag eq 'except';
    push(@tm,shift),	next SWITCH	if $flag eq 'typemap';
    $WantLineNumbers = 0, next SWITCH	if $flag eq 'nolinenumbers';
    $WantLineNumbers = 1, next SWITCH	if $flag eq 'linenumbers';
    $WantOptimize = 0, next SWITCH	if $flag eq 'nooptimize';
    $WantOptimize = 1, next SWITCH	if $flag eq 'optimize';
    $process_inout = 0, next SWITCH	if $flag eq 'noinout';
    $process_inout = 1, next SWITCH	if $flag eq 'inout';
    $process_argtypes = 0, next SWITCH	if $flag eq 'noargtypes';
    $process_argtypes = 1, next SWITCH	if $flag eq 'argtypes';
    (print "xsubpp version $XSUBPP_version\n"), exit
	if $flag eq 'v';
    die $usage;
}
if ($WantPrototypes == -1)
  { $WantPrototypes = 0}
else
  { $ProtoUsed = 1 }


@ARGV == 1 or die $usage;
($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)#
	or ($dir, $filename) = $ARGV[0] =~ m#(.*)\\(.*)#
	or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
	or ($dir, $filename) = ('.', $ARGV[0]);
chdir($dir);
$pwd = cwd();

++ $IncludedFiles{$ARGV[0]} ;

my(@XSStack) = ({type => 'none'});	# Stack of conditionals and INCLUDEs
my($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");


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;
    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';
    $junk = "" ;
    $current = \$junk;
    while (<TYPEMAP>) {
	next if /^\s*#/;
        my $line_no = $. + 1; 
	if (/^INPUT\s*$/)   { $mode = 'Input';   $current = \$junk;  next; }
	if (/^OUTPUT\s*$/)  { $mode = 'Output';  $current = \$junk;  next; }
	if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk;  next; }
	if ($mode eq 'Typemap') {
	    chomp;
	    my $line = $_ ;
            TrimWhitespace($_) ;
	    # skip blank lines and comment lines
	    next if /^$/ or /^#/ ;
	    my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
		warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
            $type = TidyType($type) ;
	    $type_kind{$type} = $kind ;
            # prototype defaults to '$'
            $proto = "\$" unless $proto ;
            warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n") 
                unless ValidProtoString($proto) ;
            $proto_letter{$type} = C_string($proto) ;
	}
	elsif (/^\s/) {
	    $$current .= $_;
	}
	elsif ($mode eq 'Input') {
	    s/\s+$//;
	    $input_expr{$_} = '';
	    $current = \$input_expr{$_};
	}
	else {
	    s/\s+$//;
	    $output_expr{$_} = '';
	    $current = \$output_expr{$_};
	}
    }
    close(TYPEMAP);
}

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

$bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*];	# ()-balanced
$cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?];		# Optional (SV*) cast
$size = qr[,\s* (??{ $bal }) ]x;		# Third arg (to setpvn)

foreach $key (keys %output_expr) {
    use re 'eval';

    my ($t, $with_size, $arg, $sarg) =
      ($output_expr{$key} =~
	 m[^ \s+ sv_set ( [iunp] ) v (n)? 	# Type, is_setpvn
	     \s* \( \s* $cast \$arg \s* ,
	     \s* ( (??{ $bal }) )		# Set from
	     ( (??{ $size }) )?			# Possible sizeof set-from
	     \) \s* ; \s* $
	  ]x);
    $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
}

$END = "!End!\n\n";		# "impossible" keyword (multiple newline)

# Match an XS keyword
$BLOCK_re= '\s*(' . join('|', qw(
	REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT 
	CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
	SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL
	)) . "|$END)\\s*:";

# Input:  ($_, @line) == unparsed input.
# Output: ($_, @line) == (rest of line, following lines).
# Return: the matched keyword if found, otherwise 0
sub check_keyword {
	$_ = shift(@line) while !/\S/ && @line;
	s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
}

my ($C_group_rex, $C_arg);
# Group in C (no support for comments or literals)
$C_group_rex = qr/ [({\[]
		   (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
		   [)}\]] /x ;
# Chunk in C without comma at toplevel (no comments):
$C_arg = qr/ (?: (?> [^()\[\]{},"']+ )
	     |   (??{ $C_group_rex })
	     |   " (?: (?> [^\\"]+ )
		   |   \\.
		   )* "		# String literal
	     |   ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal
	     )* /xs;

if ($WantLineNumbers) {
    {
	package xsubpp::counter;
	sub TIEHANDLE {
	    my ($class, $cfile) = @_;
	    my $buf = "";
	    $SECTION_END_MARKER = "#line --- \"$cfile\"";
	    $line_no = 1;
	    bless \$buf;
	}

	sub PRINT {
	    my $self = shift;
	    for (@_) {
		$$self .= $_;
		while ($$self =~ s/^([^\n]*\n)//) {
		    my $line = $1;
		    ++ $line_no;
		    $line =~ s|^\#line\s+---(?=\s)|#line $line_no|;
		    print STDOUT $line;
		}
	    }
	}

	sub PRINTF {
	    my $self = shift;
	    my $fmt = shift;
	    $self->PRINT(sprintf($fmt, @_));
	}

	sub DESTROY {
	    # Not necessary if we're careful to end with a "\n"
	    my $self = shift;
	    print STDOUT $$self;
	}
    }

    my $cfile = $filename;
    $cfile =~ s/\.xs$/.c/i or $cfile .= ".c";
    tie(*PSEUDO_STDOUT, 'xsubpp::counter', $cfile);
    select PSEUDO_STDOUT;
}

sub print_section {
    # the "do" is required for right semantics
    do { $_ = shift(@line) } while !/\S/ && @line;
    
    print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n")
	if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
    for (;  defined($_) && !/^$BLOCK_re/o;  $_ = shift(@line)) {
	print "$_\n";
    }
    print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers;
}

sub merge_section {
    my $in = '';
  
    while (!/\S/ && @line) {
        $_ = shift(@line);
    }
    
    for (;  defined($_) && !/^$BLOCK_re/o;  $_ = shift(@line)) {
	$in .= "$_\n";
    }
    chomp $in;
    return $in;
}

sub process_keyword($)
{
    my($pattern) = @_ ;
    my $kwd ;

    &{"${kwd}_handler"}() 
        while $kwd = check_keyword($pattern) ;
}

sub CASE_handler {
    blurt ("Error: `CASE:' after unconditional `CASE:'")
	if $condnum && $cond eq '';
    $cond = $_;
    TrimWhitespace($cond);
    print "   ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
    $_ = '' ;
}

sub INPUT_handler {
    for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
	last if /^\s*NOT_IMPLEMENTED_YET/;
	next unless /\S/;	# skip blank lines 

	TrimWhitespace($_) ;
	my $line = $_ ;

	# remove trailing semicolon if no initialisation
	s/\s*;$//g unless /[=;+].*\S/ ;

	# check for optional initialisation code
	my $var_init = '' ;
	$var_init = $1 if s/\s*([=;+].*)$//s ;
	$var_init =~ s/"/\\"/g;

	s/\s+/ /g;
	my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
	    or blurt("Error: invalid argument declaration '$line'"), next;

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

	$thisdone |= $var_name eq "THIS";
	$retvaldone |= $var_name eq "RETVAL";
	$var_types{$var_name} = $var_type;
	# XXXX This check is a safeguard against the unfinished conversion of
	# generate_init().  When generate_init() is fixed,
	# one can use 2-args map_type() unconditionally.
	if ($var_type =~ / \( \s* \* \s* \) /x) {
	  # Function pointers are not yet supported with &output_init!
	  print "\t" . &map_type($var_type, $var_name);
	  $name_printed = 1;
	} else {
	  print "\t" . &map_type($var_type);
	  $name_printed = 0;