xsubpp

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

			print "$func_name($func_args);\n";
		}
	}

	# do output variables
	$gotRETVAL = 0;		# 1 if RETVAL seen in OUTPUT section;
	undef $RETVAL_code ;	# code to set RETVAL (from OUTPUT section);
	# $wantRETVAL set if 'RETVAL =' autogenerated
	($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
	undef %outargs ;
	process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE"); 

	&generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
	  for grep $in_out{$_} =~ /OUT$/, keys %in_out;

	# all OUTPUT done, so now push the return value on the stack
	if ($gotRETVAL && $RETVAL_code) {
	    print "\t$RETVAL_code\n";
	} elsif ($gotRETVAL || $wantRETVAL) {
	    my $t = $WantOptimize && $targetable{$type_kind{$ret_type}};
	    my $var = 'RETVAL';
	    my $type = $ret_type;

	    # 0: type, 1: with_size, 2: how, 3: how_size
	    if ($t and not $t->[1] and $t->[0] eq 'p') {
		# PUSHp corresponds to setpvn.  Treate setpv directly
		my $what = eval qq("$t->[2]");
		warn $@ if $@;

		print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
		$prepush_done = 1;
	    }
	    elsif ($t) {
		my $what = eval qq("$t->[2]");
		warn $@ if $@;

		my $size = $t->[3];
		$size = '' unless defined $size;
		$size = eval qq("$size");
		warn $@ if $@;
		print "\tXSprePUSH; PUSH$t->[0]($what$size);\n";
		$prepush_done = 1;
	    }
	    else {
		# RETVAL almost never needs SvSETMAGIC()
		&generate_output($ret_type, 0, 'RETVAL', 0);
	    }
	}

	$xsreturn = 1 if $ret_type ne "void";
	my $num = $xsreturn;
	my $c = @outlist;
	print "\tXSprePUSH;" if $c and not $prepush_done;
	print "\tEXTEND(SP,$c);\n" if $c;
	$xsreturn += $c;
	generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;

	# do cleanup
	process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE") ;

	print Q<<"EOF" if $ScopeThisXSUB;
#   ]]
EOF
	print Q<<"EOF" if $ScopeThisXSUB and not $PPCODE;
#   LEAVE;
EOF

	# print function trailer
	print Q<<EOF;
#    ]]
EOF
	print Q<<EOF if $except;
#    BEGHANDLERS
#    CATCHALL
#	sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
#    ENDHANDLERS
EOF
	if (check_keyword("CASE")) {
	    blurt ("Error: No `CASE:' at top of function")
		unless $condnum;
	    $_ = "CASE: $_";	# Restore CASE: label
	    next;
	}
	last if $_ eq "$END:";
	death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
    }

    print Q<<EOF if $except;
#    if (errbuf[0])
#	Perl_croak(aTHX_ errbuf);
EOF

    if ($xsreturn) {
        print Q<<EOF unless $PPCODE;
#    XSRETURN($xsreturn);
EOF
    } else {
        print Q<<EOF unless $PPCODE;
#    XSRETURN_EMPTY;
EOF
    }

    print Q<<EOF;
#]]
#
EOF

    my $newXS = "newXS" ;
    my $proto = "" ;

    # Build the prototype string for the xsub
    if ($ProtoThisXSUB) {
	$newXS = "newXSproto";

	if ($ProtoThisXSUB eq 2) {
	    # User has specified empty prototype
	    $proto = ', ""' ;
	}
        elsif ($ProtoThisXSUB ne 1) {
            # User has specified a prototype
            $proto = ', "' . $ProtoThisXSUB . '"';
        }
        else {
	    my $s = ';';
            if ($min_args < $num_args)  {
                $s = ''; 
		$proto_arg[$min_args] .= ";" ;
	    }
            push @proto_arg, "$s\@" 
                if $elipsis ;
    
            $proto = ', "' . join ("", @proto_arg) . '"';
        }
    }

    if (%XsubAliases) {
	$XsubAliases{$pname} = 0 
	    unless defined $XsubAliases{$pname} ;
	while ( ($name, $value) = each %XsubAliases) {
	    push(@InitFileCode, Q<<"EOF");
#        cv = newXS(\"$name\", XS_$Full_func_name, file);
#        XSANY.any_i32 = $value ;
EOF
	push(@InitFileCode, Q<<"EOF") if $proto;
#        sv_setpv((SV*)cv$proto) ;
EOF
        }
    } 
    elsif (@Attributes) {
	    push(@InitFileCode, Q<<"EOF");
#        cv = newXS(\"$pname\", XS_$Full_func_name, file);
#        apply_attrs_string("$Package", cv, "@Attributes", 0);
EOF
    }
    elsif ($interface) {
	while ( ($name, $value) = each %Interfaces) {
	    $name = "$Package\::$name" unless $name =~ /::/;
	    push(@InitFileCode, Q<<"EOF");
#        cv = newXS(\"$name\", XS_$Full_func_name, file);
#        $interface_macro_set(cv,$value) ;
EOF
	    push(@InitFileCode, Q<<"EOF") if $proto;
#        sv_setpv((SV*)cv$proto) ;
EOF
        }
    }
    else {
	push(@InitFileCode,
	     "        ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
    }
}

# print initialization routine

print Q<<"EOF";
##ifdef __cplusplus
#extern "C"
##endif
EOF

print Q<<"EOF";
#XS(boot_$Module_cname)
EOF

print Q<<"EOF";
#[[
#    dXSARGS;
#    char* file = __FILE__;
#
EOF

print Q<<"EOF" if $WantVersionChk ;
#    XS_VERSION_BOOTCHECK ;
#
EOF

print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ;
#    {
#        CV * cv ;
#
EOF

print @InitFileCode;

print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ;
#    }
EOF

if (@BootCode)
{
    print "\n    /* Initialisation Section */\n\n" ;
    @line = @BootCode;
    print_section();
    print "\n    /* End of Initialisation Section */\n\n" ;
}

print Q<<"EOF";;
#    XSRETURN_YES;
#]]
#
EOF

warn("Please specify prototyping behavior for $filename (see perlxs manual)\n") 
    unless $ProtoUsed ;
&Exit;

sub output_init {
    local($type, $num, $var, $init, $name_printed) = @_;
    local($arg) = "ST(" . ($num - 1) . ")";

    if(  $init =~ /^=/  ) {
        if ($name_printed) {
	  eval qq/print " $init\\n"/;
	} else {
	  eval qq/print "\\t$var $init\\n"/;
	}
	warn $@   if  $@;
    } else {
	if(  $init =~ s/^\+//  &&  $num  ) {
	    &generate_init($type, $num, $var, $name_printed);
	} elsif ($name_printed) {
	    print ";\n";
	    $init =~ s/^;//;
	} else {
	    eval qq/print "\\t$var;\\n"/;
	    warn $@   if  $@;
	    $init =~ s/^;//;
	}
	$deferred .= eval qq/"\\n\\t$init\\n"/;
	warn $@   if  $@;
    }
}

sub Warn
{
    # work out the line number
    my $line_no = $line_no[@line_no - @line -1] ;
 
    print STDERR "@_ in $filename, line $line_no\n" ;
}

sub blurt 
{ 
    Warn @_ ;
    $errors ++ 
}

sub death
{
    Warn @_ ;
    exit 1 ;
}

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) =~ s/(?:Array)?(?:Ptr)?$//;
    $tk = $type_kind{$type};
    $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
    $type =~ tr/:/_/;
    blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
        unless defined $input_expr{$tk} ;
    $expr = $input_expr{$tk};
    if ($expr =~ /DO_ARRAY_ELEM/) {
        blurt("Error: '$subtype' not in typemap"), return 
	    unless defined($type_kind{$subtype});
        blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
            unless defined $input_expr{$type_kind{$subtype}} ;
	$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 ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
    	$ScopeThisXSUB = 1;
    }
    if (defined($defaults{$var})) {
	    $expr =~ s/(\t+)/$1    /g;
	    $expr =~ s/        /\t/g;
	    if ($name_printed) {
	      print ";\n";
	    } else {
	      eval qq/print "\\t$var;\\n"/;
	      warn $@   if  $@;
	    }
	    if ($defaults{$var} eq 'NO_INIT') {
		$deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
	    } else {
		$deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
	    }
	    warn $@   if  $@;
    } elsif ($ScopeThisXSUB or $expr !~ /^\t\$var =/) {
	    if ($name_printed) {
	      print ";\n";
	    } else {
	      eval qq/print "\\t$var;\\n"/;
	      warn $@   if  $@;
	    }
	    $deferred .= eval qq/"\\n$expr;\\n"/;
	    warn $@   if  $@;
    } else {
	    die "panic: do not know how to handle this branch for function pointers"
	      if $name_printed;
	    eval qq/print "$expr;\\n"/;
	    warn $@   if  $@;
    }
}

sub generate_output {
    local($type, $num, $var, $do_setmagic, $do_push) = @_;
    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));\n";
	    print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
    } else {
	    blurt("Error: '$type' not in typemap"), return
		unless defined($type_kind{$type});
            blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
                unless defined $output_expr{$type_kind{$type}} ;
	    ($ntype = $type) =~ s/\s*\*/Ptr/g;
	    $ntype =~ s/\(\)//g;
	    ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
	    $expr = $output_expr{$type_kind{$type}};
	    if ($expr =~ /DO_ARRAY_ELEM/) {
	        blurt("Error: '$subtype' not in typemap"), return
		    unless defined($type_kind{$subtype});
                blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
                    unless defined $output_expr{$type_kind{$subtype}} ;
		$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";
		warn $@   if  $@;
		print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
	    }
	    elsif ($var eq 'RETVAL') {
		if ($expr =~ /^\t\$arg = new/) {
		    # We expect that $arg has refcnt 1, so we need to
		    # mortalize it.
		    eval "print qq\a$expr\a";
		    warn $@   if  $@;
		    print "\tsv_2mortal(ST($num));\n";
		    print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
		}
		elsif ($expr =~ /^\s*\$arg\s*=/) {
		    # We expect that $arg has refcnt >=1, so we need
		    # to mortalize it!
		    eval "print qq\a$expr\a";
		    warn $@   if  $@;
		    print "\tsv_2mortal(ST(0));\n";
		    print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
		}
		else {
		    # Just hope that the entry would safely write it
		    # over an already mortalized value. By
		    # coincidence, something like $arg = &sv_undef
		    # works too.
		    print "\tST(0) = sv_newmortal();\n";
		    eval "print qq\a$expr\a";
		    warn $@   if  $@;
		    # new mortals don't have set magic
		}
	    }
	    elsif ($do_push) {
	        print "\tPUSHs(sv_newmortal());\n";
		$arg = "ST($num)";
		eval "print qq\a$expr\a";
		warn $@   if  $@;
		print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
	    }
	    elsif ($arg =~ /^ST\(\d+\)$/) {
		eval "print qq\a$expr\a";
		warn $@   if  $@;
		print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
	    }
    }
}

sub map_type {
    my($type, $varname) = @_;

    $type =~ tr/:/_/;
    $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
    if ($varname) {
      if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
	(substr $type, pos $type, 0) = " $varname ";
      } else {
	$type .= "\t$varname";
      }
    }
    $type;
}


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