xsubpp

来自「ARM上的如果你对底层感兴趣」· 代码 · 共 1,513 行 · 第 1/3 页

    }
    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)
#       croak("Usage: %s($orig_args)", GvNAME(CvGV(cv)));
EOF
    else 
      { print Q<<"EOF" if $cond }
#    if ($cond)
#	croak("Usage: $pname($orig_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|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\tcroak(\"$pname: not implemented yet\");\n";
		$_ = '' ;
	} else {
		if ($ret_type ne "void") {
			print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
				if !$retvaldone;
			$args_match{"RETVAL"} = 0;
			$var_types{"RETVAL"} = $ret_type;
		}

		print $deferred;

        process_keyword("INIT|ALIAS|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;
			print "$func_name($func_args);\n";
		}
	}

	# do output variables
	$gotRETVAL = 0;
	undef $RETVAL_code ;
	undef %outargs ;
        process_keyword("OUTPUT|ALIAS|PROTOTYPE"); 

	# all OUTPUT done, so now push the return value on the stack
	if ($gotRETVAL && $RETVAL_code) {
	    print "\t$RETVAL_code\n";
	} elsif ($gotRETVAL || $wantRETVAL) {
	    # RETVAL almost never needs SvSETMAGIC()
	    &generate_output($ret_type, 0, 'RETVAL', 0);
	}

	# do cleanup
	process_keyword("CLEANUP|ALIAS|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])
#	croak(errbuf);
EOF

    if ($ret_type ne "void" or $EXPLICIT_RETURN) {
        print Q<<EOF unless $PPCODE;
#    XSRETURN(1);
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 ($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
if ($WantCAPI) {
print Q<<"EOF";
#
##ifdef __cplusplus
#extern "C"
##endif
#XS(boot__CAPI_entry)
#[[
#    dXSARGS;
#    char* file = __FILE__;
#
EOF
} else {
print Q<<"EOF";
##ifdef __cplusplus
#extern "C"
##endif
#XS(boot_$Module_cname)
#[[
#    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

if ($WantCAPI) { 
print Q<<"EOF";
#
##define XSCAPI(name) void name(CV* cv, void* pPerl)
#
##ifdef __cplusplus
#extern "C"
##endif
#XSCAPI(boot_$Module_cname)
#[[
#    SetCPerlObj(pPerl);
#    boot__CAPI_entry(cv);
#]]
#
EOF
}

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

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

    if(  $init =~ /^=/  ) {
	eval qq/print "\\t$var $init\\n"/;
	warn $@   if  $@;
    } else {
	if(  $init =~ s/^\+//  &&  $num  ) {
	    &generate_init($type, $num, $var);
	} 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' 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' 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;
	    eval qq/print "\\t$var;\\n"/;
	    warn $@   if  $@;
	    $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 =/) {
	    eval qq/print "\\t$var;\\n"/;
	    warn $@   if  $@;
	    $deferred .= eval qq/"\\n$expr;\\n"/;
	    warn $@   if  $@;
    } else {
	    eval qq/print "$expr;\\n"/;
	    warn $@   if  $@;
    }
}

sub generate_output {
    local($type, $num, $var, $do_setmagic) = @_;
    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)), XFree((char *)$var);\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' 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' 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(0));\n";
		    print "\tSvSETMAGIC(ST(0));\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 ($arg =~ /^ST\(\d+\)$/) {
		eval "print qq\a$expr\a";
		warn $@   if  $@;
		print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
	    }
    }
}

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

    $type =~ tr/:/_/;
    $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
    $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);
}