view release on metacpan or  search on metacpan

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

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

sub _get_project_dir
{
  my $result = $PROJ_DIR;

  return $result;
}

sub get_project_dir
{
  my $result = _get_project_dir;

  if ( !defined $result )
  {
    $result = cwd;

    $result =~ s{ / local /? $}{}xms;
  }

  return $result;
}

package MechaCPAN::DestGuard
{
  use Cwd qw/cwd/;
  use Scalar::Util qw/refaddr weaken/;
  use overload '""' => sub { my $s = shift; return $$s }, fallback => 1;
  my $dest_dir;

  sub get
  {
    my $result = $dest_dir;
    if ( !defined $result )
    {
      my $pwd = App::MechaCPAN::get_project_dir;
      $dest_dir = \"$pwd/local";
      bless $dest_dir;
      $result = $dest_dir;
      weaken $dest_dir;
    }

    mkdir $dest_dir
      unless -d $dest_dir;

    return $dest_dir;
  }

  sub DESTROY
  {
    undef $dest_dir;
  }
}

sub dest_dir
{
  my $result = MechaCPAN::DestGuard::get();
  return $result;
}

sub fetch_file
{
  my $url = shift;
  my $to  = shift;

  use File::Copy qw/copy/;
  use Fatal qw/copy/;

  my $proj_dir = &dest_dir;
  my $slurp;

  local $File::Fetch::WARN;
  local $@;

  my $ff = File::Fetch->new( uri => $url );

  if ( $File::Fetch::VERSION < 0.50 )
  {
    # File::Fetch < 0.50 (versions bundled with perl before 5.26) does not
    # have an entry for https, so we have to convince it to use the http list
    # by telling it that the scheme is http. This does *NOT* change what
    # scheme the file is actually fetched with, only what client list will
    # be used/attempted. So https URIs are still fetched over https. In modern
    # versions of File::Fetch there is an https list, and that list does
    # enforce https verification
    $ff->scheme('http')
      if $ff->scheme eq 'https';
  }

  if ( ref $to eq 'SCALAR' )
  {
    $slurp = $to;
    undef $to;
  }

  my ( $dst_path, $dst_file, $result );
  if ( !defined $to )
  {
    $result = humane_tmpfile( $ff->output_file );