view release on metacpan or  search on metacpan

lib/App/MechaCPAN.pm  view on Meta::CPAN

    $line = $key;
    undef $key;
  }

  status( $key, 'RED', $line );
}

my $RESET = Term::ANSIColor::color('RESET');
my $BOLD  = Term::ANSIColor::color('BOLD');

sub _show_line
{
  my $key   = shift;
  my $color = shift;
  my $line  = shift;

  no warnings 'uninitialized';

  # If the color starts with red, it's an error and we should not touch it,
  # otherwise, we should clean up the line
  state $ERR_COLOR = Term::ANSIColor::color('RED');
  if ( $color !~ m/^\Q$ERR_COLOR/ )
  {
    $line =~ s/\n/ /xmsg;
  }

  state @key_lines;

  my $idx = first { $key_lines[$_] eq $key } 0 .. $#key_lines;

  if ( !defined $key )
  {
    # Scroll Up 1 line
    print STDERR "\n";
    $idx = -1;
  }

  # When key is _, that means we're undoing the last line
  if ( $key eq '_' )
  {
    $idx = 0;
  }

  if ( !defined $idx )
  {
    unshift @key_lines, $key;
    $idx = 0;

    # Scroll Up 1 line
    print STDERR "\n";
  }
  $idx++;

  # Don't bother with fancy line movements if we are verbose
  if ($VERBOSE)
  {
    print STDERR "$color$line$RESET\n";
    return;
  }

  # We use some ANSI escape codes, so they are:
  # \e[.F  - Move up from current line, which is always the end of the list
  # \e[K   - Clear the line
  # $color - Colorize the text
  # $line  - Print the text
  # $RESET - Reset the colorize
  # \e[.E  - Move down from the current line, back to the end of the list
  print STDERR "\e[${idx}F";
  print STDERR "\e[K";
  print STDERR "$color$line$RESET\n";
  print STDERR "\e[" . ( $idx - 1 ) . "E"
    if $idx > 1;

  return;
}

sub status
{
  my $key   = shift;
  my $color = shift;
  my $line  = shift;

  no warnings 'uninitialized';

  if ( !defined $line )
  {
    $line  = $color;
    $color = 'RESET';
  }

  # The _ key means undo the last line, but only status can do that, so treat
  # it the same as undef
  if ( $key eq '_' )
  {
    undef $key;
  }

  logmsg($line);

  return
    if $QUIET;

  $color = eval { Term::ANSIColor::color($color) } // $RESET;

  state @last_key;

  # Undo the last line that is bold
  if ( @last_key && !$VERBOSE && $last_key[0] ne $key )
  {
    _show_line(@last_key);
  }

  _show_line( $key, $color . $BOLD, $line );

  @last_key = ( $key // '_', $color, $line );
}

{
  no warnings 'void';
  END  { print STDERR "\n" unless $QUIET; }
  INIT { print STDERR "\n" unless $QUIET; }

lib/App/MechaCPAN.pm  view on Meta::CPAN

    die "Could not find module '$key' in CHECKSUMS"
      if $CHKSIGS;

    logmsg "Could not find '$key' in CHECKSUMS, not attempting to verify";
    return;
  }

  return $result;
}

my @inflate = (

  # System tar
  sub
  {
    my $src = shift;

    my $humane_qr = humane_qr;
    return
      unless $src =~ m{ [.]tar[.] (?: xz | gz | bz2|bzip2 ) $humane_qr? $}xms;

    state $tar;
    if ( !defined $tar )
    {
      my $tar_version_str = eval { run(qw/tar --version/); };
      $tar = defined $tar_version_str;
    }

    return
      unless $tar;

    my $unzip
      = $src =~ m/gz $humane_qr? $/xms          ? 'gzip'
      : $src =~ m/(bz2|bzip2) $humane_qr? $/xms ? 'bzip2'
      :                                           'xz';

    # Instead of relying on a shell to pipe contents from unzip to tar, both
    # gnutar and bsdtar accept the use-compress-program option. bsdtar needs
    # the -d option so it will decompress, while gnutar automatically adds it
    # but it is harmless to add.
    run( 'tar', '--use-compress-program', "$unzip -d", '-xf', $src );
    return 1;
  },

  # Archive::Tar
  sub
  {
    my $src = shift;

    require Archive::Tar;
    my $tar = Archive::Tar->new;
    $tar->error(1);

    my $ret = $tar->read( "$src", 1, { extract => 1 } );

    die $tar->error
      unless $ret;
  },
);

sub _path_escapes_dir
{
  my $path = shift;

  return 0
    if !defined $path;
  return 0
    if !length $path;

  return 1
    if File::Spec->file_name_is_absolute($path);

  for my $part ( File::Spec->splitdir($path) )
  {
    return 1
      if $part eq '..';
  }

  return 0;
}

# Inspect a tar archive's header entries (no extraction). Returns a
# human-readable reason if any entry would escape the destination dir
# (absolute paths, '..' traversal in names, or symlink/hardlink targets
# pointing outside). Returns undef if the archive is safe.
sub _validate_archive_is_safe
{
  my $src = shift;

  require Archive::Tar;

  # Create a tar iterator. The magic 1 tells it to decompress
  my $iter = Archive::Tar->iter( "$src", 1 );

  return "could not read archive: $src"
    if !defined $iter;

  while ( my $entry = $iter->() )
  {
    my $name = $entry->full_path;

    return "unsafe entry name: '$name'"
      if _path_escapes_dir($name);

    if ( $entry->is_symlink || $entry->is_hardlink )
    {
      my $linkname = $entry->linkname;

      return "unsafe link target: '$name' -> '$linkname'"
        if _path_escapes_dir($linkname);
    }
  }

  return;
}

sub inflate_archive
{
  my $src = shift;
  my $dir = shift;

  my $sha256;

  if ( ref $src eq 'HASH' )
  {
    $sha256 = delete $src->{sha256};

    # Technically the error is wrong, it can have an optional sha256 key,
    # but it gets people here to see that the error is that there is a
    # narrow requirement for the hashref version of inflate_archive
    die "Hashref for inflate_archive must be only the 'src' key"
      if scalar( keys %$src ) != 1 || !exists $src->{src};

    $src = $src->{src};
  }

  # $src can be a file path or a URL.
  if ( !-e "$src" )
  {
    $src = fetch_file($src);
  }

  if ($sha256)
  {
    file_digest_chk( $src, $sha256 );
    logmsg "Digest passed: $src";
  }

  if ( !defined $dir )
  {
    my $descr = ( File::Spec->splitpath($src) )[2];
    $dir = humane_tmpdir($descr);
  }

  die "Could not find destination directory: $dir"
    if !-d $dir;

  if ( my $reason = _validate_archive_is_safe($src) )
  {
    croak "Refusing to extract unsafe archive $src: $reason\n";
  }

  my $orig = cwd;

  my $is_complete;
  foreach my $inflate_sub (@inflate)
  {
    local $@;
    my $success;
    my $error_free = eval {