X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FExtUtils%2Fxsubpp;h=98bb7397f66f4150a129f24e025f3ef9ee6840f0;hb=8c7f0036c6170bb0e341d84874bdb51f472a6afb;hp=1e9ff45cc9ab8899a7389fcb850d731c6cb1247f;hpb=45645c0c182600881f3427c7498d7a9890d23152;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp
index 1e9ff45..98bb739 100755
--- a/lib/ExtUtils/xsubpp
+++ b/lib/ExtUtils/xsubpp
@@ -109,7 +109,7 @@ sub Q ;
 
 # Global Constants
 
-$XSUBPP_version = "1.9507";
+$XSUBPP_version = "1.9508";
 
 my ($Is_VMS, $SymSet);
 if ($^O eq 'VMS') {
@@ -124,9 +124,7 @@ $FH = 'File0000' ;
 
 $usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-s pattern] [-typemap typemap]... file.xs\n";
 
-$proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
-# mjn
-$OBJ   = 1 if $Config{'ccflags'} =~ /PERL_OBJECT/i;
+$proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ;
 
 $except = "";
 $WantPrototypes = -1 ;
@@ -148,7 +146,7 @@ SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
     $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';
+    next SWITCH                         if $flag eq 'object_capi';
     $except = " TRY",	next SWITCH	if $flag eq 'except';
     push(@tm,shift),	next SWITCH	if $flag eq 'typemap';
     $WantLineNumbers = 0, next SWITCH	if $flag eq 'nolinenumbers';
@@ -213,7 +211,7 @@ unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
                 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
                 ../typemap typemap);
 foreach $typemap (@tm) {
-    next unless -e $typemap ;
+    next unless -f $typemap ;
     # skip directories, binary files etc.
     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next 
 	unless -T $typemap ;
@@ -418,7 +416,7 @@ sub INPUT_handler {
 	$var_init =~ s/"/\\"/g;
 
 	s/\s+/ /g;
-	my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s
+	my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
 	    or blurt("Error: invalid argument declaration '$line'"), next;
 
 	# Check for duplicate definitions
@@ -444,12 +442,9 @@ sub INPUT_handler {
 
         $proto_arg[$var_num] = ProtoString($var_type) 
 	    if $var_num ;
-	if ($var_addr) {
-	    $var_addr{$var_name} = 1;
-	    $func_args =~ s/\b($var_name)\b/&$1/;
-	}
+	$func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
 	if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
-	    or $in_out{$var_name} and $in_out{$var_name} eq 'OUTLIST'
+	    or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
 	    and $var_init !~ /\S/) {
 	  if ($name_printed) {
 	    print ";\n";
@@ -494,6 +489,8 @@ sub OUTPUT_handler {
 	} else {
 	    &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
 	}
+	delete $in_out{$outarg} 	# No need to auto-OUTPUT 
+	  if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
     }
 }
 
@@ -859,17 +856,25 @@ print("#line 1 \"$filename\"\n")
 firstmodule:
 while (<$FH>) {
     if (/^=/) {
+        my $podstartline = $.;
     	do {
-	    next firstmodule if /^=cut\s*$/;
+	    if (/^=cut\s*$/) {
+		print("/* Skipped embedded POD. */\n");
+		printf("#line %d \"$filename\"\n", $. + 1)
+		  if $WantLineNumbers;
+		next firstmodule
+	    }
+
 	} while (<$FH>);
-	&Exit;
+	# At this point $. is at end of file so die won't state the start
+	# of the problem, and as we haven't yet read any lines &death won't
+	# show the correct line in the message either.
+	die ("Error: Unterminated pod in $filename, line $podstartline\n")
+	  unless $lastline;
     }
     last if ($Module, $Package, $Prefix) =
 	/^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
 
-    if ($OBJ) {
-        s/#if(?:def\s|\s+defined)\s*(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/;
-    }
     print $_;
 }
 &Exit unless defined $_;
@@ -986,13 +991,12 @@ while (fetch_para()) {
 
     death ("Code is not inside a function"
 	   ." (maybe last function was ended by a blank line "
-	   ." followed by a a statement on column one?)")
+	   ." followed by a statement on column one?)")
 	if $line[0] =~ /^\s/;
 
     # initialize info arrays
     undef(%args_match);
     undef(%var_types);
-    undef(%var_addr);
     undef(%defaults);
     undef($class);
     undef($static);
@@ -1004,7 +1008,7 @@ while (fetch_para()) {
     undef(@arg_with_types) ;
     undef($processing_arg_with_types) ;
     undef(%arg_types) ;
-    undef(@in_out) ;
+    undef(@outlist) ;
     undef(%in_out) ;
     undef($proto_in_this_xsub) ;
     undef($scope_in_this_xsub) ;
@@ -1070,7 +1074,7 @@ while (fetch_para()) {
 
     $orig_args =~ s/\\\s*/ /g;		# process line continuations
 
-    my %out_vars;
+    my %only_outlist;
     if ($process_argtypes and $orig_args =~ /\S/) {
 	my $args = "$orig_args ,";
 	if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
@@ -1085,10 +1089,10 @@ while (fetch_para()) {
 		next unless length $pre;
 		my $out_type;
 		my $inout_var;
-		if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST)\s+//) {
+		if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) {
 		    my $type = $1;
 		    $out_type = $type if $type ne 'IN';
-		    $arg =~ s/^(IN|IN_OUTLIST|OUTLIST)\s+//;
+		    $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
 		}
 		if (/\W/) {	# Has a type
 		    push @arg_with_types, $arg;
@@ -1096,8 +1100,8 @@ while (fetch_para()) {
 		    $arg_types{$name} = $arg;
 		    $_ = "$name$default";
 		}
-		$out_vars{$_} = 1 if $out_type eq 'OUTLIST';
-		push @in_out, $name if $out_type;
+		$only_outlist{$_} = 1 if $out_type eq "OUTLIST";
+		push @outlist, $name if $out_type =~ /OUTLIST$/;
 		$in_out{$name} = $out_type if $out_type;
 	    }
 	} else {
@@ -1107,11 +1111,11 @@ while (fetch_para()) {
     } else {
 	@args = split(/\s*,\s*/, $orig_args);
 	for (@args) {
-	    if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST)\s+//) {
+	    if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) {
 		my $out_type = $1;
 		next if $out_type eq 'IN';
-		$out_vars{$_} = 1 if $out_type eq 'OUTLIST';
-		push @in_out, $name;
+		$only_outlist{$_} = 1 if $out_type eq "OUTLIST";
+		push @outlist, $name if $out_type =~ /OUTLIST$/;
 		$in_out{$_} = $out_type;
 	    }
 	}
@@ -1135,7 +1139,7 @@ while (fetch_para()) {
 			last;
 		    }
 	    }
-	    if ($out_vars{$args[$i]}) {
+	    if ($only_outlist{$args[$i]}) {
 		push @args_num, undef;
 	    } else {
 		push @args_num, ++$num_args;
@@ -1174,6 +1178,7 @@ while (fetch_para()) {
 
     # print function header
     print Q<<"EOF";
+#XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
 #XS(XS_${Full_func_name})
 #[[
 #    dXSARGS;
@@ -1210,6 +1215,15 @@ EOF
 #	Perl_croak(aTHX_ "Usage: $pname($report_args)");
 EOF
 
+    #gcc -Wall: if an xsub has no arguments and PPCODE is used
+    #it is likely none of ST, XSRETURN or XSprePUSH macros are used
+    #hence `ax' (setup by dXSARGS) is unused
+    #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS
+    #but such a move could break third-party extensions
+    print Q<<"EOF" if $PPCODE and $num_args == 0;
+#   PERL_UNUSED_VAR(ax); /* -Wall */
+EOF
+
     print Q<<"EOF" if $PPCODE;
 #    SP -= items;
 EOF
@@ -1324,6 +1338,9 @@ EOF
 	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";
@@ -1360,11 +1377,11 @@ EOF
 
 	$xsreturn = 1 if $ret_type ne "void";
 	my $num = $xsreturn;
-	my $c = @in_out;
+	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 @in_out;
+	generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
 
 	# do cleanup
 	process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE") ;
@@ -1490,16 +1507,23 @@ print Q<<"EOF";
 EOF
 
 print Q<<"EOF";
+#XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
 #XS(boot_$Module_cname)
 EOF
 
 print Q<<"EOF";
 #[[
 #    dXSARGS;
+EOF
+
+#-Wall: if there is no $Full_func_name there are no xsubs in this .xs
+#so `file' is unused
+print Q<<"EOF" if $Full_func_name;
 #    char* file = __FILE__;
-#
 EOF
 
+print Q "#\n";
+
 print Q<<"EOF" if $WantVersionChk ;
 #    XS_VERSION_BOOTCHECK ;
 #
@@ -1607,6 +1631,7 @@ sub generate_init {
         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/\$type/\$subtype/g;
 	$subexpr =~ s/ntype/subtype/g;
 	$subexpr =~ s/\$arg/ST(ix_$var)/g;
 	$subexpr =~ s/\n\t/\n\t\t/g;
@@ -1657,6 +1682,7 @@ sub generate_output {
 
     $type = TidyType($type) ;
     if ($type =~ /^array\(([^,]*),(.*)\)/) {
+            print "\t$arg = sv_newmortal();\n";
 	    print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
 	    print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
     } else {