X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FExtUtils%2Fxsubpp;h=0cc8d785a7b4d7ad58aafa0704553f2f636e74e7;hb=248e2feabe92562dd8355cfd55ca72d937481761;hp=f2f10d797b50c15b9be640cb3549a0fc2af3aaf1;hpb=db3b9414613c95081b0f8793cee8d2af39b76e86;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp
index f2f10d7..0cc8d78 100755
--- a/lib/ExtUtils/xsubpp
+++ b/lib/ExtUtils/xsubpp
@@ -71,17 +71,29 @@ 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.938";
 require 5.002;
+use Cwd;
 use vars '$cplusplus';
 
 sub Q ;
 
+# Global Constants
+
+$XSUBPP_version = "1.9402";
+
+my ($Is_VMS, $SymSet);
+if ($^O eq 'VMS') {
+    $Is_VMS = 1;
+    # Establish set of global symbols with max length 28, since xsubpp
+    # will later add the 'XS_' prefix.
+    require ExtUtils::XSSymSet;
+    $SymSet = new ExtUtils::XSSymSet 28;
+}
+
 $FH = 'File0000' ;
 
 $usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-s pattern] [-typemap typemap]... file.xs\n";
@@ -95,7 +107,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';
@@ -118,16 +130,14 @@ else
 	or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
 	or ($dir, $filename) = ('.', $ARGV[0]);
 chdir($dir);
-# Check for VMS; Config.pm may not be installed yet, but this routine
-# is built into VMS perl
-if (defined(&VMS::Filespec::vmsify)) { $Is_VMS = 1; $pwd = $ENV{DEFAULT}; }
-else                                 { $Is_VMS = 0; chomp($pwd = `pwd`);   }
+$pwd = cwd();
 
 ++ $IncludedFiles{$ARGV[0]} ;
 
 my(@XSStack) = ({type => 'none'});	# Stack of conditionals and INCLUDEs
 my($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
 
+
 sub TrimWhitespace
 {
     $_[0] =~ s/^\s+|\s+$//go ;
@@ -169,6 +179,7 @@ foreach $typemap (@tm) {
     $current = \$junk;
     while (<TYPEMAP>) {
 	next if /^\s*#/;
+        my $line_no = $. + 1; 
 	if (/^INPUT\s*$/)   { $mode = 'Input';   $current = \$junk;  next; }
 	if (/^OUTPUT\s*$/)  { $mode = 'Output';  $current = \$junk;  next; }
 	if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk;  next; }
@@ -228,8 +239,10 @@ sub check_keyword {
 
 
 sub print_section {
+    my $count = 0;
     $_ = shift(@line) while !/\S/ && @line;
     for (;  defined($_) && !/^$BLOCK_re/o;  $_ = shift(@line)) {
+        print line_directive() unless ($count++);
 	print "$_\n";
     }
 }
@@ -241,6 +254,7 @@ sub process_keyword($)
 
     &{"${kwd}_handler"}() 
         while $kwd = check_keyword($pattern) ;
+    print line_directive();
 }
 
 sub CASE_handler {
@@ -317,6 +331,7 @@ sub OUTPUT_handler {
 	    unless defined($args_match{$outarg});
 	blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
 	    unless defined $var_types{$outarg} ;
+	print line_directive();
 	if ($outcode) {
 	    print "\t$outcode\n";
 	} else {
@@ -634,7 +649,7 @@ print <<EOM ;
  */
 
 EOM
- 
+print "#line 1 \"$filename\"\n"; 
 
 while (<$FH>) {
     last if ($Module, $Package, $Prefix) =
@@ -646,7 +661,6 @@ while (<$FH>) {
 $lastline    = $_;
 $lastline_no = $.;
 
-
 # Read next xsub into @line from ($lastline, <$FH>).
 sub fetch_para {
     # parse paragraph
@@ -661,6 +675,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;
@@ -741,7 +756,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
@@ -769,7 +786,7 @@ while (fetch_para()) {
 
     if (check_keyword("BOOT")) {
 	&check_cpp;
-        push (@BootCode, $_, @line, "") ;
+        push (@BootCode, $_, line_directive(), @line, "") ;
         next PARAGRAPH ;
     }
 
@@ -789,12 +806,14 @@ 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";
+    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 '$func_name' detected");
+	Warn("Warning: duplicate function definition '$clean_func_name' detected");
 	last;
     }
     $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
@@ -834,11 +853,15 @@ while (fetch_para()) {
 
     $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);
 
     # print function header
     print Q<<"EOF";
-#XS(XS_${Packid}_$func_name)
+#XS(XS_${Full_func_name})
 #[[
 #    dXSARGS;
 EOF
@@ -980,6 +1003,7 @@ EOF
 	} elsif ($gotRETVAL || $wantRETVAL) {
 	    &generate_output($ret_type, 0, 'RETVAL');
 	}
+	print line_directive();
 
 	# do cleanup
 	process_keyword("CLEANUP|ALIAS|PROTOTYPE") ;
@@ -1016,7 +1040,7 @@ EOF
 #	croak(errbuf);
 EOF
 
-    if ($ret_type ne "void" or $CODE) {
+    if ($ret_type ne "void" or $EXPLICIT_RETURN) {
         print Q<<EOF unless $PPCODE;
 #    XSRETURN(1);
 EOF
@@ -1132,6 +1156,15 @@ sub output_init {
     eval qq/print " $init\\\n"/;
 }
 
+sub line_directive
+{
+    # work out the line number
+    my $line_no = $line_no[@line_no - @line -1] ;
+ 
+    return "#line $line_no \"$filename\"\n" ;
+
+}
+
 sub Warn
 {
     # work out the line number
@@ -1232,15 +1265,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";
 		}
@@ -1264,5 +1309,6 @@ 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 ($Is_VMS ? ($errors ? 44 : 1) : $errors) ;
+    exit ($errors ? 1 : 0);
 }