xsubpp

MSYS在windows下模拟了一个类unix的终端

	}
	$var_num = $args_match{$var_name};

        $proto_arg[$var_num] = ProtoString($var_type) 
	    if $var_num ;
	$func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
	if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
	    or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
	    and $var_init !~ /\S/) {
	  if ($name_printed) {
	    print ";\n";
	  } else {
	    print "\t$var_name;\n";
	  }
	} elsif ($var_init =~ /\S/) {
	    &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
	} elsif ($var_num) {
	    # generate initialization code
	    &generate_init($var_type, $var_num, $var_name, $name_printed);
	} 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);
	}
	delete $in_out{$outarg} 	# No need to auto-OUTPUT 
	  if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
    }
}

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 POSTCALL_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 ATTRS_handler ()
{
    for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
	next unless /\S/;
	TrimWhitespace($_) ;
        push @Attributes, $_;
    }
}

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

sub REQUIRE_handler ()
{
    # the rest of the current line should contain a version number
    my ($Ver) = $_ ;

    TrimWhitespace($Ver) ;

    death ("Error: REQUIRE expects a version number")
	unless $Ver ;

    # check that the version number is of the form n.n
    death ("Error: REQUIRE: expected a number, got '$Ver'")
	unless $Ver =~ /^\d+(\.\d*)?/ ;

    death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.")
        unless $XSUBPP_version >= $Ver ; 
}

sub VERSIONCHECK_handler ()
{
    # the rest of the current line should contain either ENABLE or
    # DISABLE
 
    TrimWhitespace($_) ;
 
    # check for ENABLE/DISABLE
    death ("Error: VERSIONCHECK: ENABLE/DISABLE")
        unless /^(ENABLE|DISABLE)/i ;
 
    $WantVersionChk = 1 if $1 eq 'ENABLE' ;
    $WantVersionChk = 0 if $1 eq 'DISABLE' ;
 
}

sub PROTOTYPE_handler ()
{
    my $specified ;

    death("Error: Only 1 PROTOTYPE definition allowed per xsub") 
        if $proto_in_this_xsub ++ ;

    for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
	next unless /\S/;
	$specified = 1 ;
	TrimWhitespace($_) ;
        if ($_ eq 'DISABLE') {
	   $ProtoThisXSUB = 0 
        }
        elsif ($_ eq 'ENABLE') {
	   $ProtoThisXSUB = 1 
        }
        else {
            # remove any whitespace
            s/\s+//g ;
            death("Error: Invalid prototype '$_'")
                unless ValidProtoString($_) ;
            $ProtoThisXSUB = C_string($_) ;
        }
    }

    # If no prototype specified, then assume empty prototype ""
    $ProtoThisXSUB = 2 unless $specified ;

    $ProtoUsed = 1 ;

}

sub SCOPE_handler ()
{
    death("Error: Only 1 SCOPE declaration allowed per xsub") 
        if $scope_in_this_xsub ++ ;

    for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
		next unless /\S/;
		TrimWhitespace($_) ;
        if ($_ =~ /^DISABLE/i) {
		   $ScopeThisXSUB = 0 
        }
        elsif ($_ =~ /^ENABLE/i) {
		   $ScopeThisXSUB = 1 
        }
    }

}

sub PROTOTYPES_handler ()
{
    # the rest of the current line should contain either ENABLE or
    # DISABLE 

    TrimWhitespace($_) ;

    # check for ENABLE/DISABLE
    death ("Error: PROTOTYPES: ENABLE/DISABLE")
        unless /^(ENABLE|DISABLE)/i ;

    $WantPrototypes = 1 if $1 eq 'ENABLE' ;
    $WantPrototypes = 0 if $1 eq 'DISABLE' ;
    $ProtoUsed = 1 ;

}

sub INCLUDE_handler ()
{
    # the rest of the current line should contain a valid filename
 
    TrimWhitespace($_) ;
 
    death("INCLUDE: filename missing")
        unless $_ ;

    death("INCLUDE: output pipe is illegal")
        if /^\s*\|/ ;

    # simple minded recursion detector
    death("INCLUDE loop detected")
        if $IncludedFiles{$_} ;

    ++ $IncludedFiles{$_} unless /\|\s*$/ ;

    # Save the current file context.
    push(@XSStack, {
	type		=> 'file',
        LastLine        => $lastline,
        LastLineNo      => $lastline_no,
        Line            => \@line,
        LineNo          => \@line_no,
        Filename        => $filename,
        Handle          => $FH,
        }) ;
 
    ++ $FH ;

    # open the new file
    open ($FH, "$_") or death("Cannot open '$_': $!") ;
 
    print Q<<"EOF" ;
#
#/* INCLUDE:  Including '$_' from '$filename' */
#
EOF

    $filename = $_ ;

    # Prime the pump by reading the first 
    # non-blank line

    # skip leading blank lines
    while (<$FH>) {
        last unless /^\s*$/ ;
    }

    $lastline = $_ ;
    $lastline_no = $. ;
 
}
 
sub PopFile()
{
    return 0 unless $XSStack[-1]{type} eq 'file' ;

    my $data     = pop @XSStack ;
    my $ThisFile = $filename ;
    my $isPipe   = ($filename =~ /\|\s*$/) ;
 
    -- $IncludedFiles{$filename}
        unless $isPipe ;

    close $FH ;

    $FH         = $data->{Handle} ;
    $filename   = $data->{Filename} ;
    $lastline   = $data->{LastLine} ;
    $lastline_no = $data->{LastLineNo} ;
    @line       = @{ $data->{Line} } ;
    @line_no    = @{ $data->{LineNo} } ;

    if ($isPipe and $? ) {
        -- $lastline_no ;
        print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n"  ;
        exit 1 ;
    }

    print Q<<"EOF" ;
#
#/* INCLUDE: Returning to '$filename' from '$ThisFile' */
#
EOF

    return 1 ;
}

sub ValidProtoString ($)
{
    my($string) = @_ ;

    if ( $string =~ /^$proto_re+$/ ) {
        return $string ;
    }

    return 0 ;
}

sub C_string ($)
{
    my($string) = @_ ;

    $string =~ s[\\][\\\\]g ;
    $string ;
}

sub ProtoString ($)
{
    my ($type) = @_ ;

    $proto_letter{$type} or "\$" ;
}

sub check_cpp {
    my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
    if (@cpp) {
	my ($cpp, $cpplevel);
	for $cpp (@cpp) {
	    if ($cpp =~ /^\#\s*if/) {
		$cpplevel++;
	    } elsif (!$cpplevel) {
		Warn("Warning: #else/elif/endif without #if in this function");
		print STDERR "    (precede it with a blank line if the matching #if is outside the function)\n"
		    if $XSStack[-1]{type} eq 'if';
		return;
	    } elsif ($cpp =~ /^\#\s*endif/) {
		$cpplevel--;
	    }
	}
	Warn("Warning: #if without #endif in this function") if $cpplevel;
    }
}


sub Q {
    my($text) = @_;
    $text =~ s/^#//gm;
    $text =~ s/\[\[/{/g;
    $text =~ s/\]\]/}/g;
    $text;
}

open($FH, $filename) or die "cannot open $filename: $!\n";

# Identify the version of xsubpp used
print <<EOM ;
/*
 * This file was generated automatically by xsubpp version $XSUBPP_version from the 
 * contents of $filename. Do not edit this file, edit $filename instead.
 *
 *	ANY CHANGES MADE HERE WILL BE LOST! 
 *
 */

EOM
 

print("#line 1 \"$filename\"\n")
    if $WantLineNumbers;

firstmodule:
while (<$FH>) {
    if (/^=/) {
        my $podstartline = $.;
    	do {
	    if (/^=cut\s*$/) {
		print("/* Skipped embedded POD. */\n");
		printf("#line %d \"$filename\"\n", $. + 1)
		  if $WantLineNumbers;
		next firstmodule
	    }

	} while (<$FH>);
	# At this point $. is at end of file so die won't state the start
	# of the problem, and as we haven't yet read any lines &death won't
	# show the correct line in the message either.
	die ("Error: Unterminated pod in $filename, line $podstartline\n")
	  unless $lastline;
    }
    last if ($Module, $Package, $Prefix) =
	/^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;

    if ($OBJ) {
        s/#if(?:def\s|\s+defined)\s*(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/;
    }