xsubpp

UNIX下perl实现代码

    print $_;
}
&Exit unless defined $_;

print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers;

$lastline    = $_;
$lastline_no = $.;

# Read next xsub into @line from ($lastline, <$FH>).
sub fetch_para {
    # parse paragraph
    death ("Error: Unterminated `#if/#ifdef/#ifndef'")
	if !defined $lastline && $XSStack[-1]{type} eq 'if';
    @line = ();
    @line_no = () ;
    return PopFile() if !defined $lastline;

    if ($lastline =~
	/^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
	$Module = $1;
	$Package = defined($2) ? $2 : '';	# keep -w happy
	$Prefix  = defined($3) ? $3 : '';	# keep -w happy
	$Prefix = quotemeta $Prefix ;
	($Module_cname = $Module) =~ s/\W/_/g;
	($Packid = $Package) =~ tr/:/_/;
	$Packprefix = $Package;
	$Packprefix .= "::" if $Packprefix ne "";
	$lastline = "";
    }

    for(;;) {
	# Skip embedded PODs 
	while ($lastline =~ /^=/) {
    	    while ($lastline = <$FH>) {
	    	last if ($lastline =~ /^=cut\s*$/);
	    }
	    death ("Error: Unterminated pod") unless $lastline;
	    $lastline = <$FH>;
	    chomp $lastline;
	    $lastline =~ s/^\s+$//;
	}
	if ($lastline !~ /^\s*#/ ||
	    # CPP directives:
	    #	ANSI:	if ifdef ifndef elif else endif define undef
	    #		line error pragma
	    #	gcc:	warning include_next
	    #   obj-c:	import
	    #   others:	ident (gcc notes that some cpps have this one)
	    $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
	    last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
	    push(@line, $lastline);
	    push(@line_no, $lastline_no) ;
	}

	# Read next line and continuation lines
	last unless defined($lastline = <$FH>);
	$lastline_no = $.;
	my $tmp_line;
	$lastline .= $tmp_line
	    while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));

	chomp $lastline;
	$lastline =~ s/^\s+$//;
    }
    pop(@line), pop(@line_no) while @line && $line[-1] eq "";
    1;
}

PARAGRAPH:
while (fetch_para()) {
    # Print initial preprocessor statements and blank lines
    while (@line && $line[0] !~ /^[^\#]/) {
	my $line = shift(@line);
	print $line, "\n";
	next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
	my $statement = $+;
	if ($statement eq 'if') {
	    $XSS_work_idx = @XSStack;
	    push(@XSStack, {type => 'if'});
	} else {
	    death ("Error: `$statement' with no matching `if'")
		if $XSStack[-1]{type} ne 'if';
	    if ($XSStack[-1]{varname}) {
		push(@InitFileCode, "#endif\n");
		push(@BootCode,     "#endif");
	    }

	    my(@fns) = keys %{$XSStack[-1]{functions}};
	    if ($statement ne 'endif') {
		# Hide the functions defined in other #if branches, and reset.
		@{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
		@{$XSStack[-1]}{qw(varname functions)} = ('', {});
	    } else {
		my($tmp) = pop(@XSStack);
		0 while (--$XSS_work_idx
			 && $XSStack[$XSS_work_idx]{type} ne 'if');
		# Keep all new defined functions
		push(@fns, keys %{$tmp->{other_functions}});
		@{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
	    }
	}
    }

    next PARAGRAPH unless @line;

    if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
	# We are inside an #if, but have not yet #defined its xsubpp variable.
	print "#define $cpp_next_tmp 1\n\n";
	push(@InitFileCode, "#if $cpp_next_tmp\n");
	push(@BootCode,     "#if $cpp_next_tmp");
	$XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
    }

    death ("Code is not inside a function"
	   ." (maybe last function was ended by a blank line "
	   ." followed by a a statement on column one?)")
	if $line[0] =~ /^\s/;

    # initialize info arrays
    undef(%args_match);
    undef(%var_types);
    undef(%defaults);
    undef($class);
    undef($static);
    undef($elipsis);
    undef($wantRETVAL) ;
    undef($RETVAL_no_return) ;
    undef(%arg_list) ;
    undef(@proto_arg) ;
    undef(@arg_with_types) ;
    undef($processing_arg_with_types) ;
    undef(%arg_types) ;
    undef(@outlist) ;
    undef(%in_out) ;
    undef($proto_in_this_xsub) ;
    undef($scope_in_this_xsub) ;
    undef($interface);
    undef($prepush_done);
    $interface_macro = 'XSINTERFACE_FUNC' ;
    $interface_macro_set = 'XSINTERFACE_FUNC_SET' ;
    $ProtoThisXSUB = $WantPrototypes ;
    $ScopeThisXSUB = 0;
    $xsreturn = 0;

    $_ = shift(@line);
    while ($kwd = check_keyword("REQUIRE|PROTOTYPES|VERSIONCHECK|INCLUDE")) {
        &{"${kwd}_handler"}() ;
        next PARAGRAPH unless @line ;
        $_ = shift(@line);
    }

    if (check_keyword("BOOT")) {
	&check_cpp;
	push (@BootCode, "#line $line_no[@line_no - @line] \"$filename\"")
	  if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
        push (@BootCode, @line, "") ;
        next PARAGRAPH ;
    }


    # extract return type, function name and arguments
    ($ret_type) = TidyType($_);
    $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//;

    # Allow one-line ANSI-like declaration
    unshift @line, $2
      if $process_argtypes
	and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;

    # a function definition needs at least 2 lines
    blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
	unless @line ;

    $static = 1 if $ret_type =~ s/^static\s+//;

    $func_header = shift(@line);
    blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
	unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s;

    ($class, $func_name, $orig_args) =  ($1, $2, $3) ;
    $class = "$4 $class" if $4;
    ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
    ($clean_func_name = $func_name) =~ s/^$Prefix//;
    $Full_func_name = "${Packid}_$clean_func_name";
    if ($Is_VMS) { $Full_func_name = $SymSet->addsym($Full_func_name); }

    # Check for duplicate function definition
    for $tmp (@XSStack) {
	next unless defined $tmp->{functions}{$Full_func_name};
	Warn("Warning: duplicate function definition '$clean_func_name' detected");
	last;
    }
    $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
    %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = ();
    $DoSetMagic = 1;

    $orig_args =~ s/\\\s*/ /g;		# process line continuations

    my %only_outlist;
    if ($process_argtypes and $orig_args =~ /\S/) {
	my $args = "$orig_args ,";
	if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
	    @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg);
	    for ( @args ) {
		s/^\s+//;
		s/\s+$//;
		my $arg = $_;
		my $default;
		($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x;
		my ($pre, $name) = ($arg =~ /(.*?) \s* \b(\w+) \s* $ /x);
		next unless length $pre;
		my $out_type;
		my $inout_var;
		if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) {
		    my $type = $1;
		    $out_type = $type if $type ne 'IN';
		    $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
		}
		if (/\W/) {	# Has a type
		    push @arg_with_types, $arg;
		    # warn "pushing '$arg'\n";
		    $arg_types{$name} = $arg;
		    $_ = "$name$default";
		}
		$only_outlist{$_} = 1 if $out_type eq "OUTLIST";
		push @outlist, $name if $out_type =~ /OUTLIST$/;
		$in_out{$name} = $out_type if $out_type;
	    }
	} else {
	    @args = split(/\s*,\s*/, $orig_args);
	    Warn("Warning: cannot parse argument list '$orig_args', fallback to split");
	}
    } else {
	@args = split(/\s*,\s*/, $orig_args);
	for (@args) {
	    if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) {
		my $out_type = $1;
		next if $out_type eq 'IN';
		$only_outlist{$_} = 1 if $out_type eq "OUTLIST";
		push @outlist, $name if $out_type =~ /OUTLIST$/;
		$in_out{$_} = $out_type;
	    }
	}
    }
    if (defined($class)) {
	my $arg0 = ((defined($static) or $func_name eq 'new')
		    ? "CLASS" : "THIS");
	unshift(@args, $arg0);
	($report_args = "$arg0, $report_args") =~ s/^\w+, $/$arg0/;
    }
    my $extra_args = 0;
    @args_num = ();
    $num_args = 0;
    my $report_args = '';
    foreach $i (0 .. $#args) {
	    if ($args[$i] =~ s/\.\.\.//) {
		    $elipsis = 1;
		    if ($args[$i] eq '' && $i == $#args) {
		        $report_args .= ", ...";
			pop(@args);
			last;
		    }
	    }
	    if ($only_outlist{$args[$i]}) {
		push @args_num, undef;
	    } else {
		push @args_num, ++$num_args;
		$report_args .= ", $args[$i]";
	    }
	    if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
		    $extra_args++;
		    $args[$i] = $1;
		    $defaults{$args[$i]} = $2;
		    $defaults{$args[$i]} =~ s/"/\\"/g;
	    }
	    $proto_arg[$i+1] = "\$" ;
    }
    $min_args = $num_args - $extra_args;
    $report_args =~ s/"/\\"/g;
    $report_args =~ s/^,\s+//;
    my @func_args = @args;
    shift @func_args if defined($class);

    for (@func_args) {
	s/^/&/ if $in_out{$_};
    }
    $func_args = join(", ", @func_args);
    @args_match{@args} = @args_num;

    $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
    $CODE = grep(/^\s*CODE\s*:/, @line);
    # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
    #   to set explicit return values.
    $EXPLICIT_RETURN = ($CODE &&
		("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
    $ALIAS  = grep(/^\s*ALIAS\s*:/,  @line);
    $INTERFACE  = grep(/^\s*INTERFACE\s*:/,  @line);

    $xsreturn = 1 if $EXPLICIT_RETURN;

    # print function header
    print Q<<"EOF";
#XS(XS_${Full_func_name})
#[[
#    dXSARGS;
EOF
    print Q<<"EOF" if $ALIAS ;
#    dXSI32;
EOF
    print Q<<"EOF" if $INTERFACE ;
#    dXSFUNCTION($ret_type);
EOF
    if ($elipsis) {
	$cond = ($min_args ? qq(items < $min_args) : 0);
    }
    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

    if ($ALIAS) 
      { print Q<<"EOF" if $cond }
#    if ($cond)
#       Perl_croak(aTHX_ "Usage: %s($report_args)", GvNAME(CvGV(cv)));
EOF
    else 
      { print Q<<"EOF" if $cond }
#    if ($cond)
#	Perl_croak(aTHX_ "Usage: $pname($report_args)");
EOF

    print Q<<"EOF" if $PPCODE;
#    SP -= items;
EOF

    # Now do a block of some sort.

    $condnum = 0;
    $cond = '';			# last CASE: condidional
    push(@line, "$END:");
    push(@line_no, $line_no[-1]);
    $_ = '';
    &check_cpp;
    while (@line) {
	&CASE_handler if check_keyword("CASE");
	print Q<<"EOF";
#   $except [[
EOF

	# do initialization of input variables
	$thisdone = 0;
	$retvaldone = 0;
	$deferred = "";
	%arg_list = () ;
        $gotRETVAL = 0;

	INPUT_handler() ;
	process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE") ;

	print Q<<"EOF" if $ScopeThisXSUB;
#   ENTER;
#   [[
EOF
	
	if (!$thisdone && defined($class)) {
	    if (defined($static) or $func_name eq 'new') {
		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 "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
		$_ = '' ;
	} else {
		if ($ret_type ne "void") {
			print "\t" . &map_type($ret_type, 'RETVAL') . ";\n"
				if !$retvaldone;
			$args_match{"RETVAL"} = 0;
			$var_types{"RETVAL"} = $ret_type;
			print "\tdXSTARG;\n"
				if $WantOptimize and $targetable{$type_kind{$ret_type}};
		}

		if (@arg_with_types) {
		    unshift @line, @arg_with_types, $_;
		    $_ = "";
		    $processing_arg_with_types = 1;
		    INPUT_handler() ;
		}
		print $deferred;

        process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ;

		if (check_keyword("PPCODE")) {
			print_section();
			death ("PPCODE must be last thing") if @line;
			print "\tLEAVE;\n" if $ScopeThisXSUB;
			print "\tPUTBACK;\n\treturn;\n";
		} elsif (check_keyword("CODE")) {
			print_section() ;
		} elsif (defined($class) and $func_name eq "DESTROY") {
			print "\n\t";
			print "delete THIS;\n";
		} else {
			print "\n\t";
			if ($ret_type ne "void") {
				print "RETVAL = ";
				$wantRETVAL = 1;
			}
			if (defined($static)) {
			    if ($func_name eq 'new') {
				$func_name = "$class";
			    } else {
				print "${class}::";
			    }
			} elsif (defined($class)) {
			    if ($func_name eq 'new') {
				$func_name .= " $class";
			    } else {
				print "THIS->";
			    }
			}
			$func_name =~ s/^($spat)//
			    if defined($spat);
			$func_name = 'XSFUNCTION' if $interface;