Re: [PATCH] Re: INSTALLSCRIPT versus INSTALLDIRS

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

diff --git a/lib/ExtUtils/Constant.pm b/lib/ExtUtils/Constant.pm
index cd04063..c449a9b 100644 (file)
--- a/lib/ExtUtils/Constant.pm
+++ b/lib/ExtUtils/Constant.pm
@@ -243,17 +243,23 @@ EOT
   $xs .= ', &sv' if $params->{SV};
   $xs .= ");\n";
 
+  # If anyone is insane enough to suggest a package name containing %
+  my $package_sprintf_safe = $package;
+  $package_sprintf_safe =~ s/%/%%/g;
+
   $xs .= << "EOT";
       /* Return 1 or 2 items. First is error message, or undef if no error.
            Second, if present, is found value */
         switch (type) {
         case PERL_constant_NOTFOUND:
-          sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s));
+          sv =
+           sv_2mortal(newSVpvf("%s is not a valid $package_sprintf_safe macro", s));
           PUSHs(sv);
           break;
         case PERL_constant_NOTDEF:
           sv = sv_2mortal(newSVpvf(
-           "Your vendor has not defined $package macro %s, used", s));
+           "Your vendor has not defined $package_sprintf_safe macro %s, used",
+                                  s));
           PUSHs(sv);
           break;
 EOT
@@ -283,7 +289,7 @@ EOT
   $xs .= << "EOT";
         default:
           sv = sv_2mortal(newSVpvf(
-           "Unexpected return type %d while processing $package macro %s, used",
+           "Unexpected return type %d while processing $package_sprintf_safe macro %s, used",
                type, s));
           PUSHs(sv);
         }
@@ -432,6 +438,11 @@ for each group with this number or more names in.
 An array of constants' names, either scalars containing names, or hashrefs
 as detailed in L<"C_constant">.
 
+=item C_FH
+
+A filehandle to write the C code to.  If not given, then I<C_FILE> is opened
+for writing.
+
 =item C_FILE
 
 The name of the file to write containing the C code.  The default is
@@ -440,6 +451,11 @@ mistaken for anything related to a legitimate perl package name, and
 not naming the file C<.c> avoids having to override Makefile.PL's
 C<.xs> to C<.c> rules.
 
+=item XS_FH
+
+A filehandle to write the XS code to.  If not given, then I<XS_FILE> is opened
+for writing.
+
 =item XS_FILE
 
 The name of the file to write containing the XS code.  The default is
@@ -474,18 +490,28 @@ sub WriteConstants {
 
   croak "Module name not specified" unless length $ARGS{NAME};
 
-  my ($c_fh, $xs_fh);
-  if ($] <= 5.008) {
-      # We need these little games, rather than doing things unconditionally,
-      # because we're used in core Makefile.PLs before IO is available (needed
-      # by filehandle), but also we want to work on older perls where undefined
-      # scalars do not automatically turn into anonymous file handles.
-      require FileHandle;
-      $c_fh = FileHandle->new();
-      $xs_fh = FileHandle->new();
+  my $c_fh = $ARGS{C_FH};
+  if (!$c_fh) {
+      if ($] <= 5.008) {
+         # We need these little games, rather than doing things
+         # unconditionally, because we're used in core Makefile.PLs before
+         # IO is available (needed by filehandle), but also we want to work on
+         # older perls where undefined scalars do not automatically turn into
+         # anonymous file handles.
+         require FileHandle;
+         $c_fh = FileHandle->new();
+      }
+      open $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!";
+  }
+
+  my $xs_fh = $ARGS{XS_FH};
+  if (!$xs_fh) {
+      if ($] <= 5.008) {
+         require FileHandle;
+         $xs_fh = FileHandle->new();
+      }
+      open $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!";
   }
-  open $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!";
-  open $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!";
 
   # As this subroutine is intended to make code that isn't edited, there's no
   # need for the user to specify any types that aren't found in the list of
@@ -493,16 +519,9 @@ sub WriteConstants {
   
   if ($ARGS{PROXYSUBS}) {
       require ExtUtils::Constant::ProxySubs;
-      ExtUtils::Constant::ProxySubs->WriteConstants({c_fh => $c_fh,
-                                                    xs_fh => $xs_fh,
-                                                    package => $ARGS{NAME},
-                                                    c_subname
-                                                    => $ARGS{C_SUBNAME},
-                                                    xs_subname
-                                                    => $ARGS{XS_SUBNAME},
-                                                    default_type
-                                                    => $ARGS{DEFAULT_TYPE},
-                                                   }, @{$ARGS{NAMES}});
+      $ARGS{C_FH} = $c_fh;
+      $ARGS{XS_FH} = $xs_fh;
+      ExtUtils::Constant::ProxySubs->WriteConstants(%ARGS);
   } else {
       my $types = {};
 
@@ -525,8 +544,8 @@ sub WriteConstants {
                                $ARGS{C_SUBNAME});
   }
 
-  close $c_fh or warn "Error closing $ARGS{C_FILE}: $!";
-  close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!";
+  close $c_fh or warn "Error closing $ARGS{C_FILE}: $!" unless $ARGS{C_FH};
+  close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!" unless $ARGS{XS_FH};
 }
 
 1;