To: Mailing list Perl5 <perl5-porters@perl.org>

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

diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp
index 83ad03a..3463e00 100755 (executable)
--- 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
 
@@ -127,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';
@@ -370,7 +367,17 @@ sub INPUT_handler {
        $thisdone |= $var_name eq "THIS";
        $retvaldone |= $var_name eq "RETVAL";
        $var_types{$var_name} = $var_type;
-       print "\t" . &map_type($var_type);
+       # XXXX This check is a safeguard against the unfinished conversion of
+       # generate_init().  When generate_init() is fixed,
+       # one can use 2-args map_type() unconditionally.
+       if ($var_type =~ / \( \s* \* \s* \) /x) {
+         # Function pointers are not yet supported with &output_init!
+         print "\t" . &map_type($var_type, $var_name);
+         $name_printed = 1;
+       } else {
+         print "\t" . &map_type($var_type);
+         $name_printed = 0;
+       }
        $var_num = $args_match{$var_name};
 
         $proto_arg[$var_num] = ProtoString($var_type) 
@@ -380,12 +387,16 @@ sub INPUT_handler {
            $func_args =~ s/\b($var_name)\b/&$1/;
        }
        if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/) {
-           print "\t$var_name;\n";
+         if ($name_printed) {
+           print ";\n";
+         } else {
+           print "\t$var_name_after;\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, $name_printed);
        } elsif ($var_num) {
            # generate initialization code
-           &generate_init($var_type, $var_num, $var_name);
+           &generate_init($var_type, $var_num, $var_name, $name_printed);
        } else {
            print ";\n";
        }
@@ -1084,7 +1095,7 @@ EOF
                $_ = '' ;
        } else {
                if ($ret_type ne "void") {
-                       print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
+                       print "\t" . &map_type($ret_type, 'RETVAL') . ";\n"
                                if !$retvaldone;
                        $args_match{"RETVAL"} = 0;
                        $var_types{"RETVAL"} = $ret_type;
@@ -1261,24 +1272,10 @@ print Q<<"EOF";
 ##endif
 EOF
 
-if ($WantCAPI) {
-print Q<<"EOF";
-##ifdef PERL_CAPI
-#XS(boot__CAPI_entry)
-##else
-EOF
-}
-
 print Q<<"EOF";
 #XS(boot_$Module_cname)
 EOF
 
-if ($WantCAPI) {
-print Q<<"EOF";
-##endif        /* PERL_CAPI */
-EOF
-}
-
 print Q<<"EOF";
 #[[
 #    dXSARGS;
@@ -1317,36 +1314,27 @@ print Q<<"EOF";;
 #
 EOF
 
-if ($WantCAPI) { 
-print Q<<"EOF";
-##ifdef PERL_CAPI
-##define XSCAPI(name) void name(CV* cv, void* pPerl)
-#
-##ifdef __cplusplus
-#extern "C"
-##endif
-#XSCAPI(boot_$Module_cname)
-#[[
-#    boot_CAPI_handler(cv, boot__CAPI_entry, pPerl);
-#]]
-##endif        /* PERL_CAPI */
-EOF
-}
-
 warn("Please specify prototyping behavior for $filename (see perlxs manual)\n") 
     unless $ProtoUsed ;
 &Exit;
 
 sub output_init {
-    local($type, $num, $var, $init) = @_;
+    local($type, $num, $var, $init, $name_printed) = @_;
     local($arg) = "ST(" . ($num - 1) . ")";
 
     if(  $init =~ /^=/  ) {
-       eval qq/print "\\t$var $init\\n"/;
+        if ($name_printed) {
+         eval qq/print " $init\\n"/;
+       } else {
+         eval qq/print "\\t$var $init\\n"/;
+       }
        warn $@   if  $@;
     } else {
        if(  $init =~ s/^\+//  &&  $num  ) {
-           &generate_init($type, $num, $var);
+           &generate_init($type, $num, $var, $name_printed);
+       } elsif ($name_printed) {
+           print ";\n";
+           $init =~ s/^;//;
        } else {
            eval qq/print "\\t$var;\\n"/;
            warn $@   if  $@;
@@ -1415,16 +1403,26 @@ sub generate_init {
     if (defined($defaults{$var})) {
            $expr =~ s/(\t+)/$1    /g;
            $expr =~ s/        /\t/g;
-           eval qq/print "\\t$var;\\n"/;
-           warn $@   if  $@;
+           if ($name_printed) {
+             print ";\n";
+           } else {
+             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  $@;
+           if ($name_printed) {
+             print ";\n";
+           } else {
+             eval qq/print "\\t$var;\\n"/;
+             warn $@   if  $@;
+           }
            $deferred .= eval qq/"\\n$expr;\\n"/;
            warn $@   if  $@;
     } else {
+           die "panic: do not know how to handle this branch for function pointers"
+             if $name_printed;
            eval qq/print "$expr;\\n"/;
            warn $@   if  $@;
     }
@@ -1501,10 +1499,17 @@ sub generate_output {
 }
 
 sub map_type {
-    my($type) = @_;
+    my($type, $varname) = @_;
 
     $type =~ tr/:/_/;
     $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
+    if ($varname) {
+      if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
+       (substr $type, pos $type, 0) = " $varname ";
+      } else {
+       $type .= "\t$varname";
+      }
+    }
     $type;
 }