[inseparable changes from patch from perl5.003_09 to perl5.003_10]

[p5sagit/p5-mst-13.2.git] / lib / ExtUtils / xsubpp

diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp
index 13f54b4..70796bd 100755 (executable)
--- a/lib/ExtUtils/xsubpp
+++ b/lib/ExtUtils/xsubpp
@@ -71,12 +71,12 @@ See the file F<changes.pod>.
 
 =head1 SEE ALSO
 
-perl(1), perlxs(1), perlxstut(1), perlapi(1)
+perl(1), perlxs(1), perlxstut(1), perlxs(1)
 
 =cut
 
 # Global Constants
-$XSUBPP_version = "1.937";
+$XSUBPP_version = "1.940";
 require 5.002;
 use vars '$cplusplus';
 
@@ -95,7 +95,7 @@ $ProtoUsed = 0 ;
 SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
     $flag = shift @ARGV;
     $flag =~ s/^-// ;
-    $spat = shift,     next SWITCH     if $flag eq 's';
+    $spat = quotemeta shift,   next SWITCH     if $flag eq 's';
     $cplusplus = 1,    next SWITCH     if $flag eq 'C++';
     $WantPrototypes = 0, next SWITCH   if $flag eq 'noprototypes';
     $WantPrototypes = 1, next SWITCH   if $flag eq 'prototypes';
@@ -215,6 +215,7 @@ $END = "!End!\n\n";         # "impossible" keyword (multiple newline)
 $BLOCK_re= '\s*(' . join('|', qw(
        REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT 
        CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
+       SCOPE
        )) . "|$END)\\s*:";
 
 # Input:  ($_, @line) == unparsed input.
@@ -440,6 +441,24 @@ sub PROTOTYPE_handler ()
 
 }
 
+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
@@ -642,6 +661,7 @@ sub fetch_para {
        $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;
@@ -722,7 +742,9 @@ while (fetch_para()) {
        $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
     }
 
-    death ("Code is not inside a function")
+    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
@@ -737,7 +759,9 @@ while (fetch_para()) {
     undef(%arg_list) ;
     undef(@proto_arg) ;
     undef($proto_in_this_xsub) ;
+    undef($scope_in_this_xsub) ;
     $ProtoThisXSUB = $WantPrototypes ;
+    $ScopeThisXSUB = 0;
 
     $_ = shift(@line);
     while ($kwd = check_keyword("REQUIRE|PROTOTYPES|VERSIONCHECK|INCLUDE")) {
@@ -768,12 +792,13 @@ while (fetch_para()) {
 
     ($class, $func_name, $orig_args) =  ($1, $2, $3) ;
     ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
-    $Full_func_name = "${Packid}_$func_name";
+    ($clean_func_name = $func_name) =~ s/^$Prefix//;
+    $Full_func_name = "${Packid}_$clean_func_name";
 
     # Check for duplicate function definition
     for $tmp (@XSStack) {
        next unless defined $tmp->{functions}{$Full_func_name};
-       Warn("Warning: duplicate function definition '$func_name' detected");
+       Warn("Warning: duplicate function definition '$clean_func_name' detected");
        last;
     }
     $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
@@ -817,7 +842,7 @@ while (fetch_para()) {
 
     # print function header
     print Q<<"EOF";
-#XS(XS_${Packid}_$func_name)
+#XS(XS_${Full_func_name})
 #[[
 #    dXSARGS;
 EOF
@@ -876,8 +901,13 @@ EOF
         $gotRETVAL = 0;
 
        INPUT_handler() ;
-       process_keyword("INPUT|PREINIT|ALIAS|PROTOTYPE") ;
+       process_keyword("INPUT|PREINIT|ALIAS|PROTOTYPE|SCOPE") ;
 
+       print Q<<"EOF" if $ScopeThisXSUB;
+#   ENTER;
+#   [[
+EOF
+       
        if (!$thisdone && defined($class)) {
            if (defined($static) or $func_name =~ /^new/) {
                print "\tchar *";
@@ -902,12 +932,15 @@ EOF
                        $args_match{"RETVAL"} = 0;
                        $var_types{"RETVAL"} = $ret_type;
                }
+
                print $deferred;
-                process_keyword("INIT|ALIAS|PROTOTYPE") ;
+
+        process_keyword("INIT|ALIAS|PROTOTYPE") ;
 
                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() ;
@@ -955,6 +988,13 @@ EOF
        # 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;
 #    ]]
@@ -1148,12 +1188,15 @@ sub generate_init {
        $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"/;
            $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
-    } elsif ($expr !~ /^\t\$var =/) {
+    } elsif ($ScopeThisXSUB or $expr !~ /^\t\$var =/) {
            eval qq/print "\\t$var;\\n"/;
            $deferred .= eval qq/"\\n$expr;\\n"/;
     } else {
@@ -1193,15 +1236,27 @@ sub generate_output {
                eval "print qq\a$expr\a";
            }
            elsif ($var eq 'RETVAL') {
-               if ($expr =~ /^\t\$arg\s*=\s*\$var\s*;/) {
-                   eval "print qq\a$expr\a";
-                   print "\tif (SvREFCNT(ST(0))) sv_2mortal(ST(0));\n";
-               } 
-               elsif ($expr =~ /^\t\$arg = /) {
+               if ($expr =~ /^\t\$arg = new/) {
+                   # We expect that $arg has refcnt 1, so we need to
+                   # mortalize it.
                    eval "print qq\a$expr\a";
                    print "\tsv_2mortal(ST(0));\n";
                }
+               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.
+                   eval "print qq\a$expr\a";
+                   print "\tif (SvREFCNT(ST(0))) sv_2mortal(ST(0));\n";
+               }
                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";
                }