view release on metacpan or  search on metacpan

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

{
  our @EXPORT_OK = qw/
    url_re git_re git_extract_re
    has_git has_updated_git min_git_ver
    can_https
    logmsg info success error
    dest_dir get_project_dir
    fetch_file inflate_archive
    file_digest_chk get_cpan_checksums
    humane_tmpname humane_tmpfile humane_tmpdir
    parse_cpanfile
    run run_qvf restart_script
    rel_start_to_abs
    /;
  our %EXPORT_TAGS = ( go => [@EXPORT_OK] );
}

our $VERSION = '0.32';

my @commands = qw/
  perl
  install
  deploy
  /;

foreach my $cmd ( @commands )
{
  my $pkg = __PACKAGE__ . "::" . ucfirst($cmd);
  local $@;
  my ($file, $line) = ( __FILE__, __LINE__+1);
  eval qq{#line $line "$file"\nrequire $pkg};
  die $@
    if $@;
}

my $loaded_at_compile;
my $restarted_key        = 'APP_MECHACPAN_RESTARTED';
my $is_restarted_process = delete $ENV{$restarted_key};

{
  no warnings 'void';
  INIT
  {
    $loaded_at_compile = 1;
  }
}

$loaded_at_compile //= 0;

our @args = (
  'diag-run!',
  'verbose|v!',
  'quiet|q!',
  'no-log!',
  'directory|d=s',
  'build-reusable-perl!',
  'verify!',
  'help|h!',
);

# Timeout when there's no output in seconds
our $TIMEOUT = $ENV{MECHACPAN_TIMEOUT} // 60;
our $VERBOSE;    # Print output from sub commands to STDERR
our $QUIET;      # Do not print any progress to STDERR
our $LOGFH;      # File handle to send the logs to
our $LOG_ON = 1; # Default if to log or not
our $PROJ_DIR;   # The directory given with -d or pwd if not provided
our $CHKSIGS;    # Check signatures on/off/best attempt (undef)

# In certain blocks, you may see `no warnings 'uninitialized'`. Several subs
# end up doing a lot of work with comparisions that don't distinguish between
# undef and the empty string, so these warnings create more noise than useful
# feedback, and the code to silence them are not meaningfully better

sub main
{
  my @argv = @_;

  if ( $0 =~ m/zhuli/ )
  {
    no warnings 'uninitialized';

    if ( $argv[0] =~ m/^do the thing/i )
    {
      success( "zhuli$$", 'Running deployment' )
        unless $is_restarted_process;
      $argv[0] = 'deploy';
    }
    if ( $argv[0] =~ m/^do$/i
      && $argv[1] =~ m/^the$/i
      && $argv[2] =~ m/^thing$/i )
    {
      success( "zhuli$$", 'Running deployment' )
        unless $is_restarted_process;
      @argv = ( 'deploy', @argv[ 3 .. $#argv ] );
    }
  }

  my @args = (
    @App::MechaCPAN::args,
    @App::MechaCPAN::Perl::args,
    @App::MechaCPAN::Install::args,
    @App::MechaCPAN::Deploy::args,
  );
  @args = keys %{ { map { $_ => 1 } @args } };

  if ( !@argv )
  {
    my $prog = ( File::Spec->splitpath($0) )[2] || 'mechacpan';

    my @options = map {
      my ($names) = m/^([^=:!+]+)/;
      join( ', ', map { length > 1 ? "--$_" : "-$_" } split /\|/, $names );
    } @App::MechaCPAN::args;

    my $orig_fh = select STDERR;

    say "Usage: $prog [options] <command> [<args>]";
    say "";
    say "Commands:";
    say "  $_"