This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
restore compatibility with old versions of ExtUtils::ParseXS
[perl5.git] / dist / ExtUtils-ParseXS / lib / ExtUtils / ParseXS.pm
diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
index 8ac143e..106883a 100644 (file)
--- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
+++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
@@ -11,12 +11,12 @@ use Symbol;
 
 our $VERSION;
 BEGIN {
 
 our $VERSION;
 BEGIN {
-  $VERSION = '3.22';
+  $VERSION = '3.41';
+  require ExtUtils::ParseXS::Constants; ExtUtils::ParseXS::Constants->VERSION($VERSION);
+  require ExtUtils::ParseXS::CountLines; ExtUtils::ParseXS::CountLines->VERSION($VERSION);
+  require ExtUtils::ParseXS::Utilities; ExtUtils::ParseXS::Utilities->VERSION($VERSION);
+  require ExtUtils::ParseXS::Eval; ExtUtils::ParseXS::Eval->VERSION($VERSION);
 }
 }
-use ExtUtils::ParseXS::Constants $VERSION;
-use ExtUtils::ParseXS::CountLines $VERSION;
-use ExtUtils::ParseXS::Utilities $VERSION;
-use ExtUtils::ParseXS::Eval $VERSION;
 $VERSION = eval $VERSION if $VERSION =~ /_/;
 
 use ExtUtils::ParseXS::Utilities qw(
 $VERSION = eval $VERSION if $VERSION =~ /_/;
 
 use ExtUtils::ParseXS::Utilities qw(
@@ -42,6 +42,7 @@ use ExtUtils::ParseXS::Utilities qw(
 our @EXPORT_OK = qw(
   process_file
   report_error_count
 our @EXPORT_OK = qw(
   process_file
   report_error_count
+  errors
 );
 
 ##############################
 );
 
 ##############################
@@ -79,12 +80,7 @@ sub process_file {
   # Allow for $package->process_file(%hash), $obj->process_file, and process_file()
   if (@_ % 2) {
     my $invocant = shift;
   # Allow for $package->process_file(%hash), $obj->process_file, and process_file()
   if (@_ % 2) {
     my $invocant = shift;
-    if (ref($invocant)) {
-      $self = $invocant;
-    }
-    else {
-      $self = $invocant->new;
-    }
+    $self = ref($invocant) ? $invocant : $invocant->new;
   }
   else {
     $self = $Singleton;
   }
   else {
     $self = $Singleton;
@@ -123,15 +119,15 @@ sub process_file {
   }
   @{ $self->{XSStack} } = ({type => 'none'});
   $self->{InitFileCode} = [ @ExtUtils::ParseXS::Constants::InitFileCode ];
   }
   @{ $self->{XSStack} } = ({type => 'none'});
   $self->{InitFileCode} = [ @ExtUtils::ParseXS::Constants::InitFileCode ];
-  $self->{Overload}     = 0;
-  $self->{errors}       = 0;
+  $self->{Overload}     = 0; # bool
+  $self->{errors}       = 0; # count
   $self->{Fallback}     = '&PL_sv_undef';
 
   # Most of the 1500 lines below uses these globals.  We'll have to
   # clean this up sometime, probably.  For now, we just pull them out
   # of %args.  -Ken
 
   $self->{Fallback}     = '&PL_sv_undef';
 
   # Most of the 1500 lines below uses these globals.  We'll have to
   # clean this up sometime, probably.  For now, we just pull them out
   # of %args.  -Ken
 
-  $self->{hiertype} = $args{hiertype};
+  $self->{RetainCplusplusHierarchicalTypes} = $args{hiertype};
   $self->{WantPrototypes} = $args{prototypes};
   $self->{WantVersionChk} = $args{versioncheck};
   $self->{WantLineNumbers} = $args{linenumbers};
   $self->{WantPrototypes} = $args{prototypes};
   $self->{WantVersionChk} = $args{versioncheck};
   $self->{WantLineNumbers} = $args{linenumbers};
@@ -205,7 +201,7 @@ EOM
   # is a basename'd $args{filename} due to chdir above)
   open($self->{FH}, '<', $self->{filename}) or die "cannot open $self->{filename}: $!\n";
 
   # is a basename'd $args{filename} due to chdir above)
   open($self->{FH}, '<', $self->{filename}) or die "cannot open $self->{filename}: $!\n";
 
-  firstmodule:
+  FIRSTMODULE:
   while (readline($self->{FH})) {
     if (/^=/) {
       my $podstartline = $.;
   while (readline($self->{FH})) {
     if (/^=/) {
       my $podstartline = $.;
@@ -227,7 +223,7 @@ EOM
           print("#if 0\n  \"Skipped embedded POD.\"\n#endif\n");
           printf("#line %d \"%s\"\n", $. + 1, escape_file_for_line_directive($self->{filepathname}))
             if $self->{WantLineNumbers};
           print("#if 0\n  \"Skipped embedded POD.\"\n#endif\n");
           printf("#line %d \"%s\"\n", $. + 1, escape_file_for_line_directive($self->{filepathname}))
             if $self->{WantLineNumbers};
-          next firstmodule
+          next FIRSTMODULE;
         }
 
       } while (readline($self->{FH}));
         }
 
       } while (readline($self->{FH}));
@@ -297,14 +293,14 @@ EOM
       $self->{$member} = {};
     }
     $self->{proto_arg} = [];
       $self->{$member} = {};
     }
     $self->{proto_arg} = [];
-    $self->{processing_arg_with_types} = undef;
-    $self->{proto_in_this_xsub}        = undef;
-    $self->{scope_in_this_xsub}        = undef;
-    $self->{interface}                 = undef;
+    $self->{processing_arg_with_types} = 0; # bool
+    $self->{proto_in_this_xsub}        = 0; # counter & bool
+    $self->{scope_in_this_xsub}        = 0; # counter & bool
+    $self->{interface}                 = 0; # bool
     $self->{interface_macro}           = 'XSINTERFACE_FUNC';
     $self->{interface_macro_set}       = 'XSINTERFACE_FUNC_SET';
     $self->{interface_macro}           = 'XSINTERFACE_FUNC';
     $self->{interface_macro_set}       = 'XSINTERFACE_FUNC_SET';
-    $self->{ProtoThisXSUB}             = $self->{WantPrototypes};
-    $self->{ScopeThisXSUB}             = 0;
+    $self->{ProtoThisXSUB}             = $self->{WantPrototypes}; # states 0 (none), 1 (yes), 2 (empty prototype)
+    $self->{ScopeThisXSUB}             = 0; # bool
 
     my $xsreturn = 0;
 
 
     my $xsreturn = 0;
 
@@ -363,8 +359,8 @@ EOM
       last;
     }
     $self->{XSStack}->[$XSS_work_idx]{functions}{ $self->{Full_func_name} }++;
       last;
     }
     $self->{XSStack}->[$XSS_work_idx]{functions}{ $self->{Full_func_name} }++;
-    %{ $self->{XsubAliases} }     = ();
-    %{ $self->{XsubAliasValues} } = ();
+    delete $self->{XsubAliases};
+    delete $self->{XsubAliasValues};
     %{ $self->{Interfaces} }      = ();
     @{ $self->{Attributes} }      = ();
     $self->{DoSetMagic} = 1;
     %{ $self->{Interfaces} }      = ();
     @{ $self->{Attributes} }      = ();
     $self->{DoSetMagic} = 1;
@@ -472,7 +468,7 @@ EOM
         $self->{defaults}->{$args[$i]} = $2;
         $self->{defaults}->{$args[$i]} =~ s/"/\\"/g;
       }
         $self->{defaults}->{$args[$i]} = $2;
         $self->{defaults}->{$args[$i]} =~ s/"/\\"/g;
       }
-      $self->{proto_arg}->[$i+1] = '$';
+      $self->{proto_arg}->[$i+1] = '$' unless $only_C_inlist_ref->{$args[$i]};
     }
     my $min_args = $num_args - $extra_args;
     $report_args =~ s/"/\\"/g;
     }
     my $min_args = $num_args - $extra_args;
     $report_args =~ s/"/\\"/g;
@@ -524,9 +520,10 @@ EOF
 EOF
     }
     else {
 EOF
     }
     else {
-    # cv likely to be unused
+    # cv and items likely to be unused
     print Q(<<"EOF");
 #    PERL_UNUSED_VAR(cv); /* -W */
     print Q(<<"EOF");
 #    PERL_UNUSED_VAR(cv); /* -W */
+#    PERL_UNUSED_VAR(items); /* -W */
 EOF
     }
 
 EOF
     }
 
@@ -584,7 +581,7 @@ EOF
           } );
         }
         else {
           } );
         }
         else {
-          print "\t$class *";
+          print "\t" . map_type($self, "$class *");
           $self->{var_types}->{"THIS"} = "$class *";
           $self->generate_init( {
             type          => "$class *",
           $self->{var_types}->{"THIS"} = "$class *";
           $self->generate_init( {
             type          => "$class *",
@@ -691,7 +688,7 @@ EOF
         var         => $_,
         do_setmagic => $self->{DoSetMagic},
         do_push     => undef,
         var         => $_,
         do_setmagic => $self->{DoSetMagic},
         do_push     => undef,
-      } ) for grep $self->{in_out}->{$_} =~ /OUT$/, keys %{ $self->{in_out} };
+      } ) for grep $self->{in_out}->{$_} =~ /OUT$/, sort keys %{ $self->{in_out} };
 
       my $prepush_done;
       # all OUTPUT done, so now push the return value on the stack
 
       my $prepush_done;
       # all OUTPUT done, so now push the return value on the stack
@@ -802,12 +799,15 @@ EOF
 #
 EOF
 
 #
 EOF
 
-    $self->{newXS} = "newXS";
     $self->{proto} = "";
     $self->{proto} = "";
-
+    unless($self->{ProtoThisXSUB}) {
+      $self->{newXS} = "newXS_deffile";
+      $self->{file} = "";
+    }
+    else {
     # Build the prototype string for the xsub
     # Build the prototype string for the xsub
-    if ($self->{ProtoThisXSUB}) {
       $self->{newXS} = "newXSproto_portable";
       $self->{newXS} = "newXSproto_portable";
+      $self->{file} = ", file";
 
       if ($self->{ProtoThisXSUB} eq 2) {
         # User has specified empty prototype
 
       if ($self->{ProtoThisXSUB} eq 2) {
         # User has specified empty prototype
@@ -830,20 +830,20 @@ EOF
       $self->{proto} = qq{, "$self->{proto}"};
     }
 
       $self->{proto} = qq{, "$self->{proto}"};
     }
 
-    if (%{ $self->{XsubAliases} }) {
+    if ($self->{XsubAliases} and keys %{ $self->{XsubAliases} }) {
       $self->{XsubAliases}->{ $self->{pname} } = 0
         unless defined $self->{XsubAliases}->{ $self->{pname} };
       foreach my $xname (sort keys %{ $self->{XsubAliases} }) {
         my $value = $self->{XsubAliases}{$xname};
         push(@{ $self->{InitFileCode} }, Q(<<"EOF"));
       $self->{XsubAliases}->{ $self->{pname} } = 0
         unless defined $self->{XsubAliases}->{ $self->{pname} };
       foreach my $xname (sort keys %{ $self->{XsubAliases} }) {
         my $value = $self->{XsubAliases}{$xname};
         push(@{ $self->{InitFileCode} }, Q(<<"EOF"));
-#        cv = $self->{newXS}(\"$xname\", XS_$self->{Full_func_name}, file$self->{proto});
+#        cv = $self->{newXS}(\"$xname\", XS_$self->{Full_func_name}$self->{file}$self->{proto});
 #        XSANY.any_i32 = $value;
 EOF
       }
     }
     elsif (@{ $self->{Attributes} }) {
       push(@{ $self->{InitFileCode} }, Q(<<"EOF"));
 #        XSANY.any_i32 = $value;
 EOF
       }
     }
     elsif (@{ $self->{Attributes} }) {
       push(@{ $self->{InitFileCode} }, Q(<<"EOF"));
-#        cv = $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}, file$self->{proto});
+#        cv = $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});
 #        apply_attrs_string("$self->{Package}", cv, "@{ $self->{Attributes} }", 0);
 EOF
     }
 #        apply_attrs_string("$self->{Package}", cv, "@{ $self->{Attributes} }", 0);
 EOF
     }
@@ -852,18 +852,18 @@ EOF
         my $value = $self->{Interfaces}{$yname};
         $yname = "$self->{Package}\::$yname" unless $yname =~ /::/;
         push(@{ $self->{InitFileCode} }, Q(<<"EOF"));
         my $value = $self->{Interfaces}{$yname};
         $yname = "$self->{Package}\::$yname" unless $yname =~ /::/;
         push(@{ $self->{InitFileCode} }, Q(<<"EOF"));
-#        cv = $self->{newXS}(\"$yname\", XS_$self->{Full_func_name}, file$self->{proto});
+#        cv = $self->{newXS}(\"$yname\", XS_$self->{Full_func_name}$self->{file}$self->{proto});
 #        $self->{interface_macro_set}(cv,$value);
 EOF
       }
     }
 #        $self->{interface_macro_set}(cv,$value);
 EOF
       }
     }
-    elsif($self->{newXS} eq 'newXS'){ # work around P5NCI's empty newXS macro
+    elsif($self->{newXS} eq 'newXS_deffile'){ # work around P5NCI's empty newXS macro
       push(@{ $self->{InitFileCode} },
       push(@{ $self->{InitFileCode} },
-       "        $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}, file$self->{proto});\n");
+       "        $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n");
     }
     else {
       push(@{ $self->{InitFileCode} },
     }
     else {
       push(@{ $self->{InitFileCode} },
-       "        (void)$self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}, file$self->{proto});\n");
+       "        (void)$self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n");
     }
   } # END 'PARAGRAPH' 'while' loop
 
     }
   } # END 'PARAGRAPH' 'while' loop
 
@@ -873,6 +873,7 @@ EOF
 #XS_EUPXS(XS_$self->{Packid}_nil)
 #{
 #   dXSARGS;
 #XS_EUPXS(XS_$self->{Packid}_nil)
 #{
 #   dXSARGS;
+#   PERL_UNUSED_VAR(items);
 #   XSRETURN_EMPTY;
 #}
 #
 #   XSRETURN_EMPTY;
 #}
 #
@@ -881,7 +882,7 @@ EOF
     /* Making a sub named "$self->{Package}::()" allows the package */
     /* to be findable via fetchmethod(), and causes */
     /* overload::Overloaded("$self->{Package}") to return true. */
     /* Making a sub named "$self->{Package}::()" allows the package */
     /* to be findable via fetchmethod(), and causes */
     /* overload::Overloaded("$self->{Package}") to return true. */
-    (void)$self->{newXS}("$self->{Package}::()", XS_$self->{Packid}_nil, file$self->{proto});
+    (void)$self->{newXS}("$self->{Package}::()", XS_$self->{Packid}_nil$self->{file}$self->{proto});
 MAKE_FETCHMETHOD_WORK
   }
 
 MAKE_FETCHMETHOD_WORK
   }
 
@@ -896,11 +897,13 @@ EOF
   print Q(<<"EOF");
 #XS_EXTERNAL(boot_$self->{Module_cname}); /* prototype to pass -Wmissing-prototypes */
 #XS_EXTERNAL(boot_$self->{Module_cname})
   print Q(<<"EOF");
 #XS_EXTERNAL(boot_$self->{Module_cname}); /* prototype to pass -Wmissing-prototypes */
 #XS_EXTERNAL(boot_$self->{Module_cname})
-EOF
-
-  print Q(<<"EOF");
 #[[
 #[[
+##if PERL_VERSION_LE(5, 21, 5)
 #    dVAR; dXSARGS;
 #    dVAR; dXSARGS;
+##else
+#    dVAR; ${\($self->{WantVersionChk} ?
+     'dXSBOOTARGSXSAPIVERCHK;' : 'dXSBOOTARGSAPIVERCHK;')}
+##endif
 EOF
 
   #Under 5.8.x and lower, newXS is declared in proto.h as expecting a non-const
 EOF
 
   #Under 5.8.x and lower, newXS is declared in proto.h as expecting a non-const
@@ -909,11 +912,13 @@ EOF
   #-Wall: if there is no $self->{Full_func_name} there are no xsubs in this .xs
   #so 'file' is unused
   print Q(<<"EOF") if $self->{Full_func_name};
   #-Wall: if there is no $self->{Full_func_name} there are no xsubs in this .xs
   #so 'file' is unused
   print Q(<<"EOF") if $self->{Full_func_name};
-##if (PERL_REVISION == 5 && PERL_VERSION < 9)
+##if PERL_VERSION_LT(5, 9, 0)
 #    char* file = __FILE__;
 ##else
 #    const char* file = __FILE__;
 ##endif
 #    char* file = __FILE__;
 ##else
 #    const char* file = __FILE__;
 ##endif
+#
+#    PERL_UNUSED_VAR(file);
 EOF
 
   print Q("#\n");
 EOF
 
   print Q("#\n");
@@ -921,17 +926,28 @@ EOF
   print Q(<<"EOF");
 #    PERL_UNUSED_VAR(cv); /* -W */
 #    PERL_UNUSED_VAR(items); /* -W */
   print Q(<<"EOF");
 #    PERL_UNUSED_VAR(cv); /* -W */
 #    PERL_UNUSED_VAR(items); /* -W */
-##ifdef XS_APIVERSION_BOOTCHECK
+EOF
+
+  if( $self->{WantVersionChk}){
+    print Q(<<"EOF") ;
+##if PERL_VERSION_LE(5, 21, 5)
+#    XS_VERSION_BOOTCHECK;
+##  ifdef XS_APIVERSION_BOOTCHECK
 #    XS_APIVERSION_BOOTCHECK;
 #    XS_APIVERSION_BOOTCHECK;
+##  endif
 ##endif
 ##endif
+
 EOF
 EOF
+  } else {
+    print Q(<<"EOF") ;
+##if PERL_VERSION_LE(5, 21, 5) && defined(XS_APIVERSION_BOOTCHECK)
+#  XS_APIVERSION_BOOTCHECK;
+##endif
 
 
-  print Q(<<"EOF") if $self->{WantVersionChk};
-#    XS_VERSION_BOOTCHECK;
-#
 EOF
 EOF
+  }
 
 
-  print Q(<<"EOF") if defined $self->{xsubaliases} or defined $self->{interfaces};
+  print Q(<<"EOF") if defined $self->{XsubAliases} or defined $self->{interfaces};
 #    {
 #        CV * cv;
 #
 #    {
 #        CV * cv;
 #
@@ -939,7 +955,7 @@ EOF
 
   print Q(<<"EOF") if ($self->{Overload});
 #    /* register the overloading (type 'A') magic */
 
   print Q(<<"EOF") if ($self->{Overload});
 #    /* register the overloading (type 'A') magic */
-##if (PERL_REVISION == 5 && PERL_VERSION < 9)
+##if PERL_VERSION_LT(5, 9, 0)
 #    PL_amagic_generation++;
 ##endif
 #    /* The magic for overload gets a GV* via gv_fetchmeth as */
 #    PL_amagic_generation++;
 ##endif
 #    /* The magic for overload gets a GV* via gv_fetchmeth as */
@@ -953,7 +969,7 @@ EOF
 
   print @{ $self->{InitFileCode} };
 
 
   print @{ $self->{InitFileCode} };
 
-  print Q(<<"EOF") if defined $self->{xsubaliases} or defined $self->{interfaces};
+  print Q(<<"EOF") if defined $self->{XsubAliases} or defined $self->{interfaces};
 #    }
 EOF
 
 #    }
 EOF
 
@@ -965,14 +981,15 @@ EOF
   }
 
   print Q(<<'EOF');
   }
 
   print Q(<<'EOF');
-##if (PERL_REVISION == 5 && PERL_VERSION >= 9)
-#  if (PL_unitcheckav)
-#       call_list(PL_scopestack_ix, PL_unitcheckav);
-##endif
-EOF
-
-  print Q(<<"EOF");
+##if PERL_VERSION_LE(5, 21, 5)
+##  if PERL_VERSION_GE(5, 9, 0)
+#    if (PL_unitcheckav)
+#        call_list(PL_scopestack_ix, PL_unitcheckav);
+##  endif
 #    XSRETURN_YES;
 #    XSRETURN_YES;
+##else
+#    Perl_xs_boot_epilog(aTHX_ ax);
+##endif
 #]]
 #
 EOF
 #]]
 #
 EOF
@@ -996,6 +1013,7 @@ sub report_error_count {
     return $Singleton->{errors}||0;
   }
 }
     return $Singleton->{errors}||0;
   }
 }
+*errors = \&report_error_count;
 
 # Input:  ($self, $_, @{ $self->{line} }) == unparsed input.
 # Output: ($_, @{ $self->{line} }) == (rest of line, following lines).
 
 # Input:  ($self, $_, @{ $self->{line} }) == unparsed input.
 # Output: ($_, @{ $self->{line} }) == (rest of line, following lines).
@@ -1286,7 +1304,6 @@ sub get_aliases {
     Warn( $self, "Warning: Aliases '$orig_alias' and '$self->{XsubAliasValues}->{$value}' have identical values")
       if $self->{XsubAliasValues}->{$value};
 
     Warn( $self, "Warning: Aliases '$orig_alias' and '$self->{XsubAliasValues}->{$value}' have identical values")
       if $self->{XsubAliasValues}->{$value};
 
-    $self->{xsubaliases} = 1;
     $self->{XsubAliases}->{$alias} = $value;
     $self->{XsubAliasValues}->{$value} = $orig_alias;
   }
     $self->{XsubAliases}->{$alias} = $value;
     $self->{XsubAliasValues}->{$value} = $orig_alias;
   }
@@ -1328,7 +1345,7 @@ sub OVERLOAD_handler {
       $self->{Overload} = 1 unless $self->{Overload};
       my $overload = "$self->{Package}\::(".$1;
       push(@{ $self->{InitFileCode} },
       $self->{Overload} = 1 unless $self->{Overload};
       my $overload = "$self->{Package}\::(".$1;
       push(@{ $self->{InitFileCode} },
-       "        (void)$self->{newXS}(\"$overload\", XS_$self->{Full_func_name}, file$self->{proto});\n");
+       "        (void)$self->{newXS}(\"$overload\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n");
     }
   }
 }
     }
   }
 }
@@ -1564,6 +1581,25 @@ sub QuoteArgs {
   return join (' ', ($cmd, @args));
 }
 
   return join (' ', ($cmd, @args));
 }
 
+# code copied from CPAN::HandleConfig::safe_quote
+#  - that has doc saying leave if start/finish with same quote, but no code
+# given text, will conditionally quote it to protect from shell
+{
+  my ($quote, $use_quote) = $^O eq 'MSWin32'
+      ? (q{"}, q{"})
+      : (q{"'}, q{'});
+  sub _safe_quote {
+      my ($self, $command) = @_;
+      # Set up quote/default quote
+      if (defined($command)
+          and $command =~ /\s/
+          and $command !~ /[$quote]/) {
+          return qq{$use_quote$command$use_quote}
+      }
+      return $command;
+  }
+}
+
 sub INCLUDE_COMMAND_handler {
   my $self = shift;
   $_ = shift;
 sub INCLUDE_COMMAND_handler {
   my $self = shift;
   $_ = shift;
@@ -1585,7 +1621,8 @@ sub INCLUDE_COMMAND_handler {
 
   # If $^X is used in INCLUDE_COMMAND, we know it's supposed to be
   # the same perl interpreter as we're currently running
 
   # If $^X is used in INCLUDE_COMMAND, we know it's supposed to be
   # the same perl interpreter as we're currently running
-  s/^\s*\$\^X/$^X/;
+  my $X = $self->_safe_quote($^X); # quotes if has spaces
+  s/^\s*\$\^X/$X/;
 
   # open the new file
   open ($self->{FH}, "-|", $_)
 
   # open the new file
   open ($self->{FH}, "-|", $_)
@@ -1662,6 +1699,69 @@ sub Q {
   $text;
 }
 
   $text;
 }
 
+# Process "MODULE = Foo ..." lines and update global state accordingly
+sub _process_module_xs_line {
+  my ($self, $module, $pkg, $prefix) = @_;
+
+  ($self->{Module_cname} = $module) =~ s/\W/_/g;
+
+  $self->{Package} = defined($pkg) ? $pkg : '';
+  $self->{Prefix}  = quotemeta( defined($prefix) ? $prefix : '' );
+
+  ($self->{Packid} = $self->{Package}) =~ tr/:/_/;
+
+  $self->{Packprefix} = $self->{Package};
+  $self->{Packprefix} .= "::" if $self->{Packprefix} ne "";
+
+  $self->{lastline} = "";
+}
+
+# Skip any embedded POD sections
+sub _maybe_skip_pod {
+  my ($self) = @_;
+
+  while ($self->{lastline} =~ /^=/) {
+    while ($self->{lastline} = readline($self->{FH})) {
+      last if ($self->{lastline} =~ /^=cut\s*$/);
+    }
+    $self->death("Error: Unterminated pod") unless defined $self->{lastline};
+    $self->{lastline} = readline($self->{FH});
+    chomp $self->{lastline};
+    $self->{lastline} =~ s/^\s+$//;
+  }
+}
+
+# This chunk of code strips out (and parses) embedded TYPEMAP blocks
+# which support a HEREdoc-alike block syntax.
+sub _maybe_parse_typemap_block {
+  my ($self) = @_;
+
+  # This is special cased from the usual paragraph-handler logic
+  # due to the HEREdoc-ish syntax.
+  if ($self->{lastline} =~ /^TYPEMAP\s*:\s*<<\s*(?:(["'])(.+?)\1|([^\s'"]+?))\s*;?\s*$/)
+  {
+    my $end_marker = quotemeta(defined($1) ? $2 : $3);
+
+    # Scan until we find $end_marker alone on a line.
+    my @tmaplines;
+    while (1) {
+      $self->{lastline} = readline($self->{FH});
+      $self->death("Error: Unterminated TYPEMAP section") if not defined $self->{lastline};
+      last if $self->{lastline} =~ /^$end_marker\s*$/;
+      push @tmaplines, $self->{lastline};
+    }
+
+    my $tmap = ExtUtils::Typemaps->new(
+      string        => join("", @tmaplines),
+      lineno_offset => 1 + ($self->current_line_number() || 0),
+      fake_filename => $self->{filename},
+    );
+    $self->{typemap}->merge(typemap => $tmap, replace => 1);
+
+    $self->{lastline} = "";
+  }
+}
+
 # Read next xsub into @{ $self->{line} } from ($lastline, readline($self->{FH})).
 sub fetch_para {
   my $self = shift;
 # Read next xsub into @{ $self->{line} } from ($lastline, readline($self->{FH})).
 sub fetch_para {
   my $self = shift;
@@ -1671,66 +1771,38 @@ sub fetch_para {
     if !defined $self->{lastline} && $self->{XSStack}->[-1]{type} eq 'if';
   @{ $self->{line} } = ();
   @{ $self->{line_no} } = ();
     if !defined $self->{lastline} && $self->{XSStack}->[-1]{type} eq 'if';
   @{ $self->{line} } = ();
   @{ $self->{line_no} } = ();
-  return $self->PopFile() if !defined $self->{lastline};
+  return $self->PopFile() if not defined $self->{lastline}; # EOF
 
   if ($self->{lastline} =~
 
   if ($self->{lastline} =~
-      /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
-    my $Module = $1;
-    $self->{Package} = defined($2) ? $2 : ''; # keep -w happy
-    $self->{Prefix}  = defined($3) ? $3 : ''; # keep -w happy
-    $self->{Prefix} = quotemeta $self->{Prefix};
-    ($self->{Module_cname} = $Module) =~ s/\W/_/g;
-    ($self->{Packid} = $self->{Package}) =~ tr/:/_/;
-    $self->{Packprefix} = $self->{Package};
-    $self->{Packprefix} .= "::" if $self->{Packprefix} ne "";
-    $self->{lastline} = "";
+      /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/)
+  {
+    $self->_process_module_xs_line($1, $2, $3);
   }
 
   for (;;) {
   }
 
   for (;;) {
-    # Skip embedded PODs
-    while ($self->{lastline} =~ /^=/) {
-      while ($self->{lastline} = readline($self->{FH})) {
-        last if ($self->{lastline} =~ /^=cut\s*$/);
-      }
-      $self->death("Error: Unterminated pod") unless $self->{lastline};
-      $self->{lastline} = readline($self->{FH});
-      chomp $self->{lastline};
-      $self->{lastline} =~ s/^\s+$//;
-    }
-
-    # This chunk of code strips out (and parses) embedded TYPEMAP blocks
-    # which support a HEREdoc-alike block syntax.
-    # This is special cased from the usual paragraph-handler logic
-    # due to the HEREdoc-ish syntax.
-    if ($self->{lastline} =~ /^TYPEMAP\s*:\s*<<\s*(?:(["'])(.+?)\1|([^\s'"]+?))\s*;?\s*$/) {
-      my $end_marker = quotemeta(defined($1) ? $2 : $3);
-      my @tmaplines;
-      while (1) {
-        $self->{lastline} = readline($self->{FH});
-        $self->death("Error: Unterminated typemap") if not defined $self->{lastline};
-        last if $self->{lastline} =~ /^$end_marker\s*$/;
-        push @tmaplines, $self->{lastline};
-      }
-
-      my $tmapcode = join "", @tmaplines;
-      my $tmap = ExtUtils::Typemaps->new(
-        string => $tmapcode,
-        lineno_offset => ($self->current_line_number()||0)+1,
-        fake_filename => $self->{filename},
-      );
-      $self->{typemap}->merge(typemap => $tmap, replace => 1);
-
-      $self->{lastline} = "";
-    }
-
-    if ($self->{lastline} !~ /^\s*#/ ||
-    # CPP directives:
-    #    ANSI:    if ifdef ifndef elif else endif define undef
-    #        line error pragma
-    #    gcc:    warning include_next
-    #   obj-c:    import
-    #   others:    ident (gcc notes that some cpps have this one)
-    $self->{lastline} =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
+    $self->_maybe_skip_pod;
+
+    $self->_maybe_parse_typemap_block;
+
+    if ($self->{lastline} !~ /^\s*#/ # not a CPP directive
+        # CPP directives:
+        #    ANSI:    if ifdef ifndef elif else endif define undef
+        #        line error pragma
+        #    gcc:    warning include_next
+        #   obj-c:    import
+        #   others:    ident (gcc notes that some cpps have this one)
+        || $self->{lastline} =~ /^\#[ \t]*
+                                  (?:
+                                        (?:if|ifn?def|elif|else|endif|
+                                           define|undef|pragma|error|
+                                           warning|line\s+\d+|ident)
+                                        \b
+                                      | (?:include(?:_next)?|import)
+                                        \s* ["<] .* [>"]
+                                 )
+                                /x
+    )
+    {
       last if $self->{lastline} =~ /^\S/ && @{ $self->{line} } && $self->{line}->[-1] eq "";
       push(@{ $self->{line} }, $self->{lastline});
       push(@{ $self->{line_no} }, $self->{lastline_no});
       last if $self->{lastline} =~ /^\S/ && @{ $self->{line} } && $self->{line}->[-1] eq "";
       push(@{ $self->{line} }, $self->{lastline});
       push(@{ $self->{line_no} }, $self->{lastline_no});
@@ -1746,27 +1818,27 @@ sub fetch_para {
     chomp $self->{lastline};
     $self->{lastline} =~ s/^\s+$//;
   }
     chomp $self->{lastline};
     $self->{lastline} =~ s/^\s+$//;
   }
-  pop(@{ $self->{line} }), pop(@{ $self->{line_no} }) while @{ $self->{line} } && $self->{line}->[-1] eq "";
-  1;
+
+  # Nuke trailing "line" entries until there's one that's not empty
+  pop(@{ $self->{line} }), pop(@{ $self->{line_no} })
+    while @{ $self->{line} } && $self->{line}->[-1] eq "";
+
+  return 1;
 }
 
 sub output_init {
   my $self = shift;
   my $argsref = shift;
 
 }
 
 sub output_init {
   my $self = shift;
   my $argsref = shift;
 
-  my ($type, $num, $var, $init, $printed_name) = (
-    $argsref->{type},
-    $argsref->{num},
-    $argsref->{var},
-    $argsref->{init},
-    $argsref->{printed_name}
-  );
+  my ($type, $num, $var, $init, $printed_name)
+    = @{$argsref}{qw(type num var init printed_name)};
+
   # local assign for efficiently passing in to eval_input_typemap_code
   local $argsref->{arg} = $num
                           ? "ST(" . ($num-1) . ")"
                           : "/* not a parameter */";
 
   # local assign for efficiently passing in to eval_input_typemap_code
   local $argsref->{arg} = $num
                           ? "ST(" . ($num-1) . ")"
                           : "/* not a parameter */";
 
-  if (  $init =~ /^=/  ) {
+  if ( $init =~ /^=/ ) {
     if ($printed_name) {
       $self->eval_input_typemap_code(qq/print " $init\\n"/, $argsref);
     }
     if ($printed_name) {
       $self->eval_input_typemap_code(qq/print " $init\\n"/, $argsref);
     }
@@ -1800,28 +1872,29 @@ sub generate_init {
   my $self = shift;
   my $argsref = shift;
 
   my $self = shift;
   my $argsref = shift;
 
-  my ($type, $num, $var, $printed_name) = (
-    $argsref->{type},
-    $argsref->{num},
-    $argsref->{var},
-    $argsref->{printed_name},
-  );
+  my ($type, $num, $var, $printed_name)
+    = @{$argsref}{qw(type num var printed_name)};
 
 
-  my $arg = "ST(" . ($num - 1) . ")";
   my $argoff = $num - 1;
   my $argoff = $num - 1;
+  my $arg = "ST($argoff)";
 
   my $typemaps = $self->{typemap};
 
   $type = ExtUtils::Typemaps::tidy_type($type);
 
   my $typemaps = $self->{typemap};
 
   $type = ExtUtils::Typemaps::tidy_type($type);
-  $self->report_typemap_failure($typemaps, $type), return
-    unless $typemaps->get_typemap(ctype => $type);
+  if (not $typemaps->get_typemap(ctype => $type)) {
+    $self->report_typemap_failure($typemaps, $type);
+    return;
+  }
 
   (my $ntype = $type) =~ s/\s*\*/Ptr/g;
   (my $subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
 
   my $typem = $typemaps->get_typemap(ctype => $type);
   my $xstype = $typem->xstype;
 
   (my $ntype = $type) =~ s/\s*\*/Ptr/g;
   (my $subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
 
   my $typem = $typemaps->get_typemap(ctype => $type);
   my $xstype = $typem->xstype;
-  $xstype =~ s/OBJ$/REF/ if $self->{func_name} =~ /DESTROY$/;
+  #this is an optimization from perl 5.0 alpha 6, class check is skipped
+  #T_REF_IV_REF is missing since it has no untyped analog at the moment
+  $xstype =~ s/OBJ$/REF/ || $xstype =~ s/^T_REF_IV_PTR$/T_PTRREF/
+    if $self->{func_name} =~ /DESTROY$/;
   if ($xstype eq 'T_PV' and exists $self->{lengthof}->{$var}) {
     print "\t$var" unless $printed_name;
     print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
   if ($xstype eq 'T_PV' and exists $self->{lengthof}->{$var}) {
     print "\t$var" unless $printed_name;
     print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
@@ -1829,21 +1902,29 @@ sub generate_init {
       if defined $self->{defaults}->{$var};
     return;
   }
       if defined $self->{defaults}->{$var};
     return;
   }
-  $type =~ tr/:/_/ unless $self->{hiertype};
+  $type =~ tr/:/_/ unless $self->{RetainCplusplusHierarchicalTypes};
 
   my $inputmap = $typemaps->get_inputmap(xstype => $xstype);
 
   my $inputmap = $typemaps->get_inputmap(xstype => $xstype);
-  $self->blurt("Error: No INPUT definition for type '$type', typekind '" . $type->xstype . "' found"), return
-    unless defined $inputmap;
+  if (not defined $inputmap) {
+    $self->blurt("Error: No INPUT definition for type '$type', typekind '" . $type->xstype . "' found");
+    return;
+  }
 
   my $expr = $inputmap->cleaned_code;
   # Note: This gruesome bit either needs heavy rethinking or documentation. I vote for the former. --Steffen
   if ($expr =~ /DO_ARRAY_ELEM/) {
     my $subtypemap  = $typemaps->get_typemap(ctype => $subtype);
 
   my $expr = $inputmap->cleaned_code;
   # Note: This gruesome bit either needs heavy rethinking or documentation. I vote for the former. --Steffen
   if ($expr =~ /DO_ARRAY_ELEM/) {
     my $subtypemap  = $typemaps->get_typemap(ctype => $subtype);
-    $self->report_typemap_failure($typemaps, $subtype), return
-      if not $subtypemap;
+    if (not $subtypemap) {
+      $self->report_typemap_failure($typemaps, $subtype);
+      return;
+    }
+
     my $subinputmap = $typemaps->get_inputmap(xstype => $subtypemap->xstype);
     my $subinputmap = $typemaps->get_inputmap(xstype => $subtypemap->xstype);
-    $self->blurt("Error: No INPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"), return
-      unless $subinputmap;
+    if (not $subinputmap) {
+      $self->blurt("Error: No INPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found");
+      return;
+    }
+
     my $subexpr = $subinputmap->cleaned_code;
     $subexpr =~ s/\$type/\$subtype/g;
     $subexpr =~ s/ntype/subtype/g;
     my $subexpr = $subinputmap->cleaned_code;
     $subexpr =~ s/\$type/\$subtype/g;
     $subexpr =~ s/ntype/subtype/g;
@@ -1910,13 +1991,9 @@ sub generate_init {
 sub generate_output {
   my $self = shift;
   my $argsref = shift;
 sub generate_output {
   my $self = shift;
   my $argsref = shift;
-  my ($type, $num, $var, $do_setmagic, $do_push) = (
-    $argsref->{type},
-    $argsref->{num},
-    $argsref->{var},
-    $argsref->{do_setmagic},
-    $argsref->{do_push}
-  );
+  my ($type, $num, $var, $do_setmagic, $do_push)
+    = @{$argsref}{qw(type num var do_setmagic do_push)};
+
   my $arg = "ST(" . ($num - ($num != 0)) . ")";
 
   my $typemaps = $self->{typemap};
   my $arg = "ST(" . ($num - ($num != 0)) . ")";
 
   my $typemaps = $self->{typemap};
@@ -1931,11 +2008,17 @@ sub generate_output {
   }
   else {
     my $typemap = $typemaps->get_typemap(ctype => $type);
   }
   else {
     my $typemap = $typemaps->get_typemap(ctype => $type);
-    $self->report_typemap_failure($typemaps, $type), return
-      if not $typemap;
+    if (not $typemap) {
+      $self->report_typemap_failure($typemaps, $type);
+      return;
+    }
+
     my $outputmap = $typemaps->get_outputmap(xstype => $typemap->xstype);
     my $outputmap = $typemaps->get_outputmap(xstype => $typemap->xstype);
-    $self->blurt("Error: No OUTPUT definition for type '$type', typekind '" . $typemap->xstype . "' found"), return
-      unless $outputmap;
+    if (not $outputmap) {
+      $self->blurt("Error: No OUTPUT definition for type '$type', typekind '" . $typemap->xstype . "' found");
+      return;
+    }
+
     (my $ntype = $type) =~ s/\s*\*/Ptr/g;
     $ntype =~ s/\(\)//g;
     (my $subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
     (my $ntype = $type) =~ s/\s*\*/Ptr/g;
     $ntype =~ s/\(\)//g;
     (my $subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
@@ -1944,11 +2027,17 @@ sub generate_output {
     my $expr = $outputmap->cleaned_code;
     if ($expr =~ /DO_ARRAY_ELEM/) {
       my $subtypemap = $typemaps->get_typemap(ctype => $subtype);
     my $expr = $outputmap->cleaned_code;
     if ($expr =~ /DO_ARRAY_ELEM/) {
       my $subtypemap = $typemaps->get_typemap(ctype => $subtype);
-      $self->report_typemap_failure($typemaps, $subtype), return
-        if not $subtypemap;
+      if (not $subtypemap) {
+        $self->report_typemap_failure($typemaps, $subtype);
+        return;
+      }
+
       my $suboutputmap = $typemaps->get_outputmap(xstype => $subtypemap->xstype);
       my $suboutputmap = $typemaps->get_outputmap(xstype => $subtypemap->xstype);
-      $self->blurt("Error: No OUTPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"), return
-        unless $suboutputmap;
+      if (not $suboutputmap) {
+        $self->blurt("Error: No OUTPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found");
+        return;
+      }
+
       my $subexpr = $suboutputmap->cleaned_code;
       $subexpr =~ s/ntype/subtype/g;
       $subexpr =~ s/\$arg/ST(ix_$var)/g;
       my $subexpr = $suboutputmap->cleaned_code;
       $subexpr =~ s/ntype/subtype/g;
       $subexpr =~ s/\$arg/ST(ix_$var)/g;
@@ -1959,36 +2048,78 @@ sub generate_output {
       print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
     }
     elsif ($var eq 'RETVAL') {
       print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
     }
     elsif ($var eq 'RETVAL') {
+      my $orig_arg = $arg;
+      my $indent;
+      my $use_RETVALSV = 1;
+      my $do_mortal = 0;
+      my $do_copy_tmp = 1;
+      my $pre_expr;
+      local $eval_vars->{arg} = $arg = 'RETVALSV';
       my $evalexpr = $self->eval_output_typemap_code("qq\a$expr\a", $eval_vars);
       my $evalexpr = $self->eval_output_typemap_code("qq\a$expr\a", $eval_vars);
+
       if ($expr =~ /^\t\Q$arg\E = new/) {
         # We expect that $arg has refcnt 1, so we need to
         # mortalize it.
       if ($expr =~ /^\t\Q$arg\E = new/) {
         # We expect that $arg has refcnt 1, so we need to
         # mortalize it.
-        print $evalexpr;
-        print "\tsv_2mortal(ST($num));\n";
-        print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
+        $do_mortal = 1;
       }
       # If RETVAL is immortal, don't mortalize it. This code is not perfect:
       # It won't detect a func or expression that only returns immortals, for
       # example, this RE must be tried before next elsif.
       elsif ($evalexpr =~ /^\t\Q$arg\E\s*=\s*(boolSV\(|(&PL_sv_yes|&PL_sv_no|&PL_sv_undef)\s*;)/) {
       }
       # If RETVAL is immortal, don't mortalize it. This code is not perfect:
       # It won't detect a func or expression that only returns immortals, for
       # example, this RE must be tried before next elsif.
       elsif ($evalexpr =~ /^\t\Q$arg\E\s*=\s*(boolSV\(|(&PL_sv_yes|&PL_sv_no|&PL_sv_undef)\s*;)/) {
-        print $evalexpr;
+        $do_copy_tmp = 0; #$arg will be a ST(X), no SV* RETVAL, no RETVALSV
+        $use_RETVALSV = 0;
       }
       elsif ($evalexpr =~ /^\s*\Q$arg\E\s*=/) {
         # We expect that $arg has refcnt >=1, so we need
         # to mortalize it!
       }
       elsif ($evalexpr =~ /^\s*\Q$arg\E\s*=/) {
         # We expect that $arg has refcnt >=1, so we need
         # to mortalize it!
-        print $evalexpr;
-        print "\tsv_2mortal(ST(0));\n";
-        print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
+        $use_RETVALSV = 0 if $ntype eq "SVPtr";#reuse SV* RETVAL vs open new block
+        $do_mortal = 1;
       }
       else {
         # Just hope that the entry would safely write it
         # over an already mortalized value. By
       }
       else {
         # Just hope that the entry would safely write it
         # over an already mortalized value. By
-        # coincidence, something like $arg = &sv_undef
+        # coincidence, something like $arg = &PL_sv_undef
         # works too, but should be caught above.
         # works too, but should be caught above.
-        print "\tST(0) = sv_newmortal();\n";
-        print $evalexpr;
+        $pre_expr = "RETVALSV = sv_newmortal();\n";
         # new mortals don't have set magic
         # new mortals don't have set magic
+        $do_setmagic = 0;
+      }
+      if($use_RETVALSV) {
+        print "\t{\n\t    SV * RETVALSV;\n";
+        $indent = "\t    ";
+      } else {
+        $indent = "\t";
+      }
+      print $indent.$pre_expr if $pre_expr;
+
+      if($use_RETVALSV) {
+        #take control of 1 layer of indent, may or may not indent more
+        $evalexpr =~ s/^(\t|        )/$indent/gm;
+        #"\t    \t" doesn't draw right in some IDEs
+        #break down all \t into spaces
+        $evalexpr =~ s/\t/        /g;
+        #rebuild back into \t'es, \t==8 spaces, indent==4 spaces
+        $evalexpr =~ s/        /\t/g;
+      }
+      else {
+        if($do_mortal || $do_setmagic) {
+        #typemap entry evaled with RETVALSV, if we aren't using RETVALSV replace
+          $evalexpr =~ s/RETVALSV/RETVAL/g; #all uses with RETVAL for prettier code
+        }
+        else { #if no extra boilerplate (no mortal, no set magic) is needed
+            #after $evalexport, get rid of RETVALSV's visual cluter and change
+          $evalexpr =~ s/RETVALSV/$orig_arg/g;#the lvalue to ST(X)
+        }
       }
       }
+      #stop "  RETVAL = RETVAL;" for SVPtr type
+      print $evalexpr if $evalexpr !~ /^\s*RETVAL = RETVAL;$/;
+      print $indent.'RETVAL'.($use_RETVALSV ? 'SV':'')
+            .' = sv_2mortal(RETVAL'.($use_RETVALSV ? 'SV':'').");\n" if $do_mortal;
+      print $indent.'SvSETMAGIC(RETVAL'.($use_RETVALSV ? 'SV':'').");\n" if $do_setmagic;
+      #dont do "RETVALSV = boolSV(RETVAL); ST(0) = RETVALSV;", it is visual clutter
+      print $indent."$orig_arg = RETVAL".($use_RETVALSV ? 'SV':'').";\n"
+        if $do_mortal || $do_setmagic || $do_copy_tmp;
+      print "\t}\n" if $use_RETVALSV;
     }
     elsif ($do_push) {
       print "\tPUSHs(sv_newmortal());\n";
     }
     elsif ($do_push) {
       print "\tPUSHs(sv_newmortal());\n";
Unnamed repository; edit this file 'description' to name the repository.