view release on metacpan or  search on metacpan

lib/Perl/Dist/Strawberry/Step.pm  view on Meta::CPAN

      $filename = _convert_name($filename);
      my $status = $member->extractToFileNamed($filename);

      die 'Error in archive extraction' if $status != AZ_OK;
      push @files, $filename;
    }
  }
  return @files;
}

sub _extract { #XXX-FIXME maybe remove leading _
  my ( $self, $from, $to ) = @_;
  File::Path::mkpath($to);
  my $wd = $self->_push_dir($to);

  my @filelist;

  $self->boss->message( 2, "* extracting '$from'" );
  if ( $from =~ /\.zip$/i ) {
    my $zip = Archive::Zip->new($from);
    die "Could not open archive $from for extraction" if !defined $zip;

    # I can't just do an extractTree here, as I'm trying to keep track of what got extracted.
    my @members = $zip->members();
    foreach my $member (@members) {
      my $filename = $member->fileName();
      $filename = _convert_name($filename); # Converts filename to Windows format.
      my $status = $member->extractToFileNamed($filename);
      die 'Error in archive extraction' if $status != AZ_OK;
      push @filelist, $filename;
    }
  }
  elsif ( $from =~ /\.(tar\.gz|tgz|tar\.bz2|tbz|tar)$/i ) {
    local $Archive::Tar::CHMOD = 0;
    my @fl = @filelist = Archive::Tar->extract_archive( $from, 1 );
    @filelist = map { catfile( $to, $_ ) } @fl;
    die 'Error in archive extraction' if !@filelist;
  }
  elsif ( $from =~ /\.(tar\.xz|txz)$/ ) {
    # First attempt at trying to use .xz files. TODO: Improve.
    eval {
      require IO::Uncompress::UnXz;
      IO::Uncompress::UnXz->VERSION(2.025);
      1;
    } or die "Tried to extract the file $from without the xz libraries installed";
    local $Archive::Tar::CHMOD = 0;
    my $xz = IO::Uncompress::UnXz->new( $from, BlockSize => 16_384 );
    my @fl = @filelist = Archive::Tar->extract_archive($xz);
    @filelist = map { catfile( $to, $_ ) } @fl;
    die 'Error in archive extraction' if !@filelist;
  }
  else {
    die "Didn't recognize archive type for $from";
  }

  return @filelist;
}

sub _convert_name {
  my $name     = shift;
  my @paths    = split m{\/}ms, $name;
  my $filename = pop @paths;
  $filename //= '';
  my $local_dirs = @paths ? catdir(@paths) : '';
  my $local_name = catpath('', $local_dirs, $filename);
  $local_name = rel2abs($local_name);
  return $local_name;
}

sub get_path_string {
  my $self = shift;

  my @p = ( catdir($self->global->{image_dir}, qw/perl site bin/),
            catdir($self->global->{image_dir}, qw/perl bin/),
            catdir($self->global->{image_dir}, qw/c bin/) );
  return join ';', @p;
}

sub execute_standard {
  my ($self, $cmd, $out, $err, $env) = @_;
  $err = $out if scalar(@_) <= 3;
  $env = {} unless $env;
  my %original_env = %ENV;
  local %ENV;
  %ENV = (%original_env, %$env);

  my $output_dir = $self->global->{output_dir};
  make_path($output_dir) unless -d $output_dir;

  # Execute the child process
  $self->boss->message(4, "execute_standard stdout='$out'\n") if $out;
  $self->boss->message(4, "execute_standard stderr='$err'\n") if $err;
  $self->boss->message(4, "execute_standard cmd=".pp($cmd)."\n");
  my $exit_code;
  my $rv = IPC::Run3::run3($cmd, \undef, $out, $err);
  $exit_code = $? if $rv;
  $self->boss->message(4, "execute_standard exit_code=$exit_code\n");
  return $exit_code;
}

sub execute_special {
  my ($self, $cmd, $out, $err, $env) = @_;
  $err = $out if scalar(@_) <= 3;
  $env = {} unless $env;
  my %original_env = %ENV;
  local %ENV;
  %ENV = (%original_env, %{$self->global->{build_ENV}}, %$env); #SPECIAL

  $self->boss->message(4, "execute_special PATH='$ENV{PATH}'\n");

  my $output_dir = $self->global->{output_dir};
  make_path($output_dir) unless -d $output_dir;

  # Execute the child process
  $self->boss->message(4, "execute_special stdout='$out'\n") if $out;
  $self->boss->message(4, "execute_special stderr='$err'\n") if $err;
  $self->boss->message(6, "execute_special env=".pp(\%ENV)."\n");
  $self->boss->message(4, "execute_special cmd=".pp($cmd)."\n");
  my $exit_code;
  my $rv = IPC::Run3::run3($cmd, \undef, $out, $err);
  $exit_code = $? if $rv;