App-MechaCPAN

 view release on metacpan or  search on metacpan

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

  }
  $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"

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

    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);

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

  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;

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

  (?: authors/id/ )?
  (?: \w / \w\w /)?

  ( \w{2,} )
  /
  ( .+ )

  $
]xms;

sub _escape
{
  my $str = shift;
  $str =~ s/ ([^A-Za-z0-9\-\._~]) / sprintf("%%%02X", ord($1)) /xmsge;
  return $str;
}

my $ident_re = qr/^ \p{ID_Start} (?: :: | \p{ID_Continue} )* $/xms;

sub _src_normalize
{

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

{
  my $src        = shift;
  my $constraint = shift // '';

  state %seen;

  return $seen{$src}->{$constraint}
    if exists $seen{$src}->{$constraint};

  # TODO mirrors
  my $dnld = 'https://fastapi.metacpan.org/download_url/' . _escape($src);
  if ( $constraint )
  {
    $dnld .= '?version=' . _escape($constraint);
  }

  my $json_info = '';
  fetch_file( $dnld => \$json_info );

  my $result = JSON::PP::decode_json($json_info);
  $seen{$src}->{$constraint} = $result;

  return $result;
}

test_dists/build-ShadyTars.pl  view on Meta::CPAN

    $tar->add_data(@$file);
  }
  $tar->write( $path, COMPRESS_GZIP );

  print "wrote $path\n";
}

# .. traversal in name
gen_tar 'traversal.tar.gz' => (
  [
    '../escape.txt' => 'traversal payload',
    { %attrs, type => FILE }
  ]
);

# absolute path
gen_tar 'absolute_path.tar.gz' => (
  [
    '/tmp/escape.txt' => 'absolute payload',
    { %attrs, type => FILE }
  ]
);

# absolute symlink destination
gen_tar 'symlink_absolute.tar.gz' => (
  [
    'link' => '',
    { %attrs, type => SYMLINK, linkname => '/tmp' }
  ],

test_dists/build-ShadyTars.pl  view on Meta::CPAN

    'hardlink' => '',
    { %attrs, type => HARDLINK, linkname => '/tmp/etc/passwd' }
  ]
);

# symlink write-through
# first entry creates a symlink pointing outside, then the second entry write
# through to a target file
gen_tar 'symlink_writethrough.tar.gz' => (
  [
    'escape' => '',
    { %attrs, type => SYMLINK, linkname => '/tmp' }
  ],
  [
    'escape/payload.txt' => 'wrote through symlink',
    { %attrs, type => FILE }
  ],
);

# benign control tar
my $mfpl = "use ExtUtils::MakeMaker;\nWriteMakefile(NAME => 'Foo');\n";
my $lib  = "package Foo;\nour \$VERSION = '1.0';\n1;\n";
gen_tar 'benign.tar.gz' => (
  [
    'dist-1.0/Makefile.PL' => $mfpl,