X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FExtUtils%2Fxsubpp;h=e5c7e0989e6c39688a7732aa386bb70fd7a449a2;hb=773ae483b9833dec8b7ccd7abbf3ce6ed04d3d69;hp=378e4811ac8554e46ff4732d637fc4690eeefff9;hpb=cfc02341d853e4bc320d3abf8ac8ac1c7c3ecaa5;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp
index 378e481..e5c7e09 100755
--- a/lib/ExtUtils/xsubpp
+++ b/lib/ExtUtils/xsubpp
@@ -6,7 +6,7 @@ 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
+B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-typemap typemap>] ... file.xs
 
 =head1 DESCRIPTION
 
@@ -59,11 +59,7 @@ number.
 
 Prevents the inclusion of `#line' directives in the output.
 
-=item B<-object_capi>
-
-Compile code as C in a PERL_OBJECT environment.
-
-back
+=back
 
 =head1 ENVIRONMENT
 
@@ -86,6 +82,7 @@ perl(1), perlxs(1), perlxstut(1)
 require 5.002;
 use Cwd;
 use vars '$cplusplus';
+use vars '%v';
 
 use Config;
 
@@ -126,6 +123,7 @@ SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
     $WantPrototypes = 1, next SWITCH	if $flag eq 'prototypes';
     $WantVersionChk = 0, next SWITCH	if $flag eq 'noversioncheck';
     $WantVersionChk = 1, next SWITCH	if $flag eq 'versioncheck';
+    # XXX left this in for compat
     $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';
@@ -351,11 +349,11 @@ sub INPUT_handler {
 	my $line = $_ ;
 
 	# remove trailing semicolon if no initialisation
-	s/\s*;$//g unless /=/ ;
+	s/\s*;$//g unless /[=;+].*\S/ ;
 
 	# check for optional initialisation code
 	my $var_init = '' ;
-	$var_init = $1 if s/\s*(=.*)$//s ;
+	$var_init = $1 if s/\s*([=;+].*)$//s ;
 	$var_init =~ s/"/\\"/g;
 
 	s/\s+/ /g;
@@ -378,10 +376,10 @@ sub INPUT_handler {
 	    $var_addr{$var_name} = 1;
 	    $func_args =~ s/\b($var_name)\b/&$1/;
 	}
-	if ($var_init =~ /^=\s*NO_INIT\s*;?\s*$/) {
+	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");
+	    &output_init($var_type, $var_num, $var_name, $var_init);
 	} elsif ($var_num) {
 	    # generate initialization code
 	    &generate_init($var_type, $var_num, $var_name);
@@ -775,7 +773,7 @@ while (<$FH>) {
 	/^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
 
     if ($OBJ) {
-        s/#if(?:def|\s+defined)\s+(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/;
+        s/#if(?:def\s|\s+defined)\s*(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/;
     }
     print $_;
 }
@@ -932,9 +930,10 @@ while (fetch_para()) {
 
     $func_header = shift(@line);
     blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
-	unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*$/s;
+	unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\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";
@@ -1022,12 +1021,12 @@ EOF
     if ($ALIAS) 
       { print Q<<"EOF" if $cond }
 #    if ($cond)
-#       croak("Usage: %s($orig_args)", GvNAME(CvGV(cv)));
+#       Perl_croak(aTHX_ "Usage: %s($orig_args)", GvNAME(CvGV(cv)));
 EOF
     else 
       { print Q<<"EOF" if $cond }
 #    if ($cond)
-#	croak("Usage: $pname($orig_args)");
+#	Perl_croak(aTHX_ "Usage: $pname($orig_args)");
 EOF
 
     print Q<<"EOF" if $PPCODE;
@@ -1078,7 +1077,7 @@ EOF
 
 	# do code
 	if (/^\s*NOT_IMPLEMENTED_YET/) {
-		print "\n\tcroak(\"$pname: not implemented yet\");\n";
+		print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
 		$_ = '' ;
 	} else {
 		if ($ret_type ne "void") {
@@ -1174,7 +1173,7 @@ EOF
 
     print Q<<EOF if $except;
 #    if (errbuf[0])
-#	croak(errbuf);
+#	Perl_croak(aTHX_ errbuf);
 EOF
 
     if ($ret_type ne "void" or $EXPLICIT_RETURN) {
@@ -1252,30 +1251,23 @@ EOF
 }
 
 # 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)
+EOF
+
+print Q<<"EOF";
 #[[
 #    dXSARGS;
 #    char* file = __FILE__;
 #
 EOF
-}
 
 print Q<<"EOF" if $WantVersionChk ;
 #    XS_VERSION_BOOTCHECK ;
@@ -1303,39 +1295,33 @@ if (@BootCode)
 }
 
 print Q<<"EOF";;
-#    ST(0) = &sv_yes;
-#    XSRETURN(1);
-#]]
-#
-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);
+#    XSRETURN_YES;
 #]]
 #
 EOF
-}
 
 warn("Please specify prototyping behavior for $filename (see perlxs manual)\n") 
     unless $ProtoUsed ;
 &Exit;
 
-
 sub output_init {
-    local($type, $num, $init) = @_;
+    local($type, $num, $var, $init) = @_;
     local($arg) = "ST(" . ($num - 1) . ")";
 
-    eval qq/print " $init\\\n"/;
+    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
@@ -1397,12 +1383,17 @@ sub generate_init {
 	    $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  $@;
     }
 }
 
@@ -1437,6 +1428,7 @@ sub generate_output {
 		$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') {
@@ -1444,18 +1436,16 @@ sub generate_output {
 		    # 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. However, the extension may have
-		    # returned the built-in perl value, which is
-		    # read-only, thus not mortalizable. However, it is
-		    # safe to leave it as it is, since it would be
-		    # ignored by REFCNT_dec. Builtin values have REFCNT==0.
+		    # to mortalize it!
 		    eval "print qq\a$expr\a";
-		    print "\tif (SvREFCNT(ST(0))) sv_2mortal(ST(0));\n";
+		    warn $@   if  $@;
+		    print "\tsv_2mortal(ST(0));\n";
 		    print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
 		}
 		else {
@@ -1465,11 +1455,13 @@ sub generate_output {
 		    # 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;
 	    }
     }