view release on metacpan or  search on metacpan

local/lib/perl5/Module/Build/Platform/Windows.pm  view on Meta::CPAN

  foreach my $script (@_) {

    # Native batch script
    if ( $script =~ /\.(bat|cmd)$/ ) {
      $self->SUPER::make_executable($script);
      next;

    # Perl script that needs to be wrapped in a batch script
    } else {
      my %opts = ();
      if ( $script eq $self->build_script ) {
        $opts{ntargs}    = q(-x -S %0 --build_bat %*);
        $opts{otherargs} = q(-x -S "%0" --build_bat %1 %2 %3 %4 %5 %6 %7 %8 %9);
      }

      my $out = eval {$self->pl2bat(in => $script, update => 1, %opts)};
      if ( $@ ) {
        $self->log_warn("WARNING: Unable to convert file '$script' to an executable script:\n$@");
      } else {
        $self->SUPER::make_executable($out);
      }
    }
  }
}

sub pl2bat {
  my $self = shift;
  my %opts = @_;
  require ExtUtils::PL2Bat;
  return ExtUtils::PL2Bat::pl2bat(%opts);
}


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 @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 split_like_shell {
  # As it turns out, Windows command-parsing is very different from
  # Unix command-parsing.  Double-quotes mean different things,
  # backslashes don't necessarily mean escapes, and so on.  So we
  # can't use Text::ParseWords::shellwords() to break a command string
  # into words.  The algorithm below was bashed out by Randy and Ken
  # (mostly Randy), and there are a lot of regression tests, so we
  # should feel free to adjust if desired.

  (my $self, local $_) = @_;

  return @$_ if defined() && ref() eq 'ARRAY';

  my @argv;
  return @argv unless defined() && length();

  my $length = length;
  m/\G\s*/gc;

  ARGS: until ( pos == $length ) {
    my $quote_mode;
    my $arg = '';
    CHARS: until ( pos == $length ) {
      if ( m/\G((?:\\\\)+)(?=\\?(")?)/gc ) {
          if (defined $2) {
              $arg .= '\\' x (length($1) / 2);
          }
          else {
              $arg .= $1;
          }
      }
      elsif ( m/\G\\"/gc ) {
        $arg .= '"';
      }
      elsif ( m/\G"/gc ) {
        if ( $quote_mode && m/\G"/gc ) {
            $arg .= '"';
        }
        $quote_mode = !$quote_mode;
      }
      elsif ( !$quote_mode && m/\G\s+/gc ) {
        last;
      }
      elsif ( m/\G(.)/sgc ) {
        $arg .= $1;
      }
    }
    push @argv, $arg;
  }

  return @argv;
}


# system(@cmd) does not like having double-quotes in it on Windows.
# So we quote them and run it as a single command.
sub do_system {
  my ($self, @cmd) = @_;

  my $cmd = $self->_quote_args(@cmd);
  my $status = system($cmd);
  if ($status and $! =~ /Argument list too long/i) {
    my $env_entries = '';
    foreach (sort keys %ENV) { $env_entries .= "$_=>".length($ENV{$_})."; " }