[Module-build-checkins] Module-Build/lib/Module/Build Base.pm,1.564,1.565

[Ken W. <kwi...@us...>]

Update of /cvsroot/module-build/Module-Build/lib/Module/Build
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv27541/lib/Module/Build

Modified Files:
	Base.pm 
Log Message:
Fix some VMS quoting issues and add _backticks() and _quote_args() methods

Index: Base.pm
===================================================================
RCS file: /cvsroot/module-build/Module-Build/lib/Module/Build/Base.pm,v
retrieving revision 1.564
retrieving revision 1.565
diff -u -d -r1.564 -r1.565
--- Base.pm	21 Mar 2006 05:03:52 -0000	1.564
+++ Base.pm	24 Mar 2006 23:26:41 -0000	1.565
@@ -314,23 +314,64 @@
   return Cwd::cwd();
 }
 
+sub _quote_args {
+  # Returns a string that can become [part of] a command line with
+  # proper quoting so that the subprocess sees this same list of args.
+  my ($self, @args) = @_;
+
+  my $return_args = '';
+  my @quoted;
+
+  for (@args) {
+    if ( /^[^\s*?!$<>;\\|'"\[\]\{\}]+$/ ) {
+      # Looks pretty safe
+      push @quoted, $_;
+    } else {
+      # XXX this will obviously have to improve - is there already a
+      # core module lying around that does proper quoting?
+      s/"/"'"'"/g;
+      push @quoted, qq("$_");
+    }
+  }
+
+  return join " ", @quoted;
+}
+
+sub _backticks {
+  # Tries to avoid using true backticks, when possible, so that we
+  # don't have to worry about shell args.
+
+  my ($self, @cmd) = @_;
+  if ($] >= 5.008) {
+    local *FH;
+    open FH, "-|", @cmd or die "Can't run @cmd: $!";
+    return wantarray ? <FH> : join '', <FH>;
+  } else {
+    my $cmd = $self->_quote_args(@cmd);
+    return `$cmd`;
+  }
+}
+
+
 # Determine whether a given binary is the same as the perl
 # (configuration) that started this process.
 sub _perl_is_same {
   my ($self, $perl) = @_;
 
+  my @cmd = ($perl);
+
   # When run from the perl core, @INC will include the directories
   # where perl is yet to be installed. We need to reference the
   # absolute path within the source distribution where it can find
   # it's Config.pm This also prevents us from picking up a Config.pm
   # from a different configuration that happens to be already
   # installed in @INC.
-  my $INC = '';
   if ($ENV{PERL_CORE}) {
-    $INC = '-I' . File::Spec->catdir(File::Basename::dirname($perl), 'lib');
+    push @cmd, '-I' . File::Spec->catdir(File::Basename::dirname($perl), 'lib');
   }
 
-  return `$perl $INC -MConfig=myconfig -e print -e myconfig` eq Config->myconfig;
+  push @cmd, qw(-MConfig=myconfig -e print -e myconfig);
+  return $self->_backticks(@cmd) eq Config->myconfig;
 }
 
 # Returns the absolute path of the perl interperter used to invoke
@@ -2080,7 +2121,7 @@
   
   foreach my $file (keys %$files) {
     my $result = $self->copy_if_modified($file, $script_dir, 'flatten') or next;
-    $self->fix_shebang_line($result);
+    $self->fix_shebang_line($result) unless $self->os_type eq 'VMS';
     $self->make_executable($result);
   }
 }
@@ -2167,6 +2208,7 @@
 
 sub localize_file_path {
   my ($self, $path) = @_;
+  $path =~ s/\.\z// if $self->os_type eq 'VMS';
   return File::Spec->catfile( split m{/}, $path );
 }
 
@@ -3669,6 +3711,7 @@
   # this before documenting.
   my ($self, $args) = @_;
   $args = [ $self->split_like_shell($args) ] unless ref($args);
+  $args = [ split(/\s+/, $self->_quote_args($args)) ] if $self->os_type eq 'VMS';
   my $perl = ref($self) ? $self->perl : $self->find_perl_interpreter;
 
   # Make sure our local additions to @INC are propagated to the subprocess