xsubpp

ARM上的如果你对底层感兴趣

#!./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<-typemap typemap>] [B<-object_capi>]... 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.

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

Compile code as C in a PERL_OBJECT environment.

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.9507";

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] [-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 ;
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';
    $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';
    (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+$//;
}

$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 PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
	SCOPE INTERFACE INTERFACE_MACRO C_ARGS
	)) . "|$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;
}


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) = /^(.*?[^& ]) *(\&?) *\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} ++  ;

	$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};

        $proto_arg[$var_num] = ProtoString($var_type) 
	    if $var_num ;
	if ($var_addr) {
	    $var_addr{$var_name} = 1;
	    $func_args =~ s/\b($var_name)\b/&$1/;
	}
	if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/) {
	    print "\t$var_name;\n";
	} elsif ($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";
	}
    }
}

sub OUTPUT_handler {
    for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
	next unless /\S/;
	if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
	    $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
	    next;
	}
	my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
	blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
	    if $outargs{$outarg} ++ ;
	if (!$gotRETVAL and $outarg eq 'RETVAL') {
	    # deal with RETVAL last
	    $RETVAL_code = $outcode ;
	    $gotRETVAL = 1 ;
	    next ;
	}
	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} ;
	$var_num = $args_match{$outarg};
	if ($outcode) {
	    print "\t$outcode\n";
	    print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
	} else {
	    &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
	}
    }
}

sub C_ARGS_handler() {
    my $in = merge_section();
  
    TrimWhitespace($in);
    $func_args = $in;
} 

sub INTERFACE_MACRO_handler() {
    my $in = merge_section();
  
    TrimWhitespace($in);
    if ($in =~ /\s/) {		# two
        ($interface_macro, $interface_macro_set) = split ' ', $in;
    } else {
        $interface_macro = $in;
	$interface_macro_set = 'UNKNOWN_CVT'; # catch later
    }
    $interface = 1;		# local
    $Interfaces = 1;		# global
}

sub INTERFACE_handler() {
    my $in = merge_section();
  
    TrimWhitespace($in);
    
    foreach (split /[\s,]+/, $in) {
        $Interfaces{$_} = $_;
    }
    print Q<<"EOF";
#	XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
EOF
    $interface = 1;		# local
    $Interfaces = 1;		# global
}

sub CLEANUP_handler() { print_section() } 
sub PREINIT_handler() { print_section() } 
sub INIT_handler()    { print_section() } 

sub GetAliases
{
    my ($line) = @_ ;
    my ($orig) = $line ;
    my ($alias) ;
    my ($value) ;

    # Parse alias definitions
    # format is
    #    alias = value alias = value ...

    while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
        $alias = $1 ;
        $orig_alias = $alias ;
        $value = $2 ;

        # check for optional package definition in the alias
	$alias = $Packprefix . $alias if $alias !~ /::/ ;
        
        # check for duplicate alias name & duplicate value
	Warn("Warning: Ignoring duplicate alias '$orig_alias'")
	    if defined $XsubAliases{$alias} ;

	Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
	    if $XsubAliasValues{$value} ;

	$XsubAliases = 1;
	$XsubAliases{$alias} = $value ;
	$XsubAliasValues{$value} = $orig_alias ;
    }

    blurt("Error: Cannot parse ALIAS definitions from '$orig'")
        if $line ;
}

sub ALIAS_handler ()
{
    for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
	next unless /\S/;
	TrimWhitespace($_) ;
        GetAliases($_) if $_ ;