view release on metacpan or  search on metacpan

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

my %COL = (
   ( map { $_ => Convert::Color->new( "vga:$_" ) } qw( red blue green ) ),
   grey => Convert::Color->new( "xterm:grey(70%)" ),
);

# Allow conversion of signal numbers into names
use Config;
my @SIGNAMES = split m/\s+/, $Config{sig_name};

=head1 NAME

C<App::eachperl> - a wrapper script for iterating multiple F<perl> binaries

=head1 SYNOPSIS

   $ eachperl exec -E 'say "Hello"'

     --- perl5.30.0 --- 
   Hello

     --- bleadperl --- 
   Hello

   ----------
   perl5.30.0          : 0
   bleadperl           : 0

=head1 DESCRIPTION

For more detail see the manpage for the eachperl(1) script.

=cut

my $VersionString_re;
my $VersionString;
BEGIN {
   $VersionString = Data::Checks::StrMatch
      $VersionString_re = qr/^v?\d+(?:\.\d+)*$/;
}

field $_finder;

field $_perls;
field $_install_no_system :param                                = undef;
field $_no_system_perl = !!$ENV{NO_SYSTEM_PERL};
field $_no_test;
field $_since_version;
field $_until_version;
field $_use_devel;
field $_only_if;
field $_reverse;
field $_stop_on_fail;

field $_io_term = IO::Term::Status->new_for_stdout;

class App::eachperl::_Perl {
   field $name         :param :reader  :Checked(Str);
   field $fullpath     :param :reader  :Checked(Str);
   field $version      :param :reader  :Checked($VersionString);
   field $is_threads   :param :reader;
   field $is_debugging :param :reader;
   field $is_devel     :param :reader;
   field $selected            :mutator;
}

field @_perlobjs;

ADJUST
{
   $_finder = Commandable::Finder::MethodAttributes->new( object => $self );

   $_finder->add_global_options(
      { name => "no-system-perl", into => \$_no_system_perl,
         description => "Deselects the system perl version" },
      { name => "no-test", into => \$_no_test,
         description => "Skips the 'test' step when building a local distribution" },
      { name => "since=", into => \$_since_version,
         matches => $VersionString_re, match_msg => "a version string",
         description => "Selects only perl versions that are at least as new as the requested version" },
      { name => "until=", into => \$_until_version,
         matches => $VersionString_re, match_msg => "a version string",
         description => "Selects only perl versions that are at least as old as the requested version" },
      { name => "version|v=", into => sub { $_since_version = $_until_version = $_[1] },
         matches => $VersionString_re, match_msg => "a version string",
         description => "Selects only the given perl version" },
      { name => "devel", into => \$_use_devel, mode => "bool",
         description => "Select only perl versions that are (or are not) development versions" },
      { name => "only-if=", into => \$_only_if,
         description => "Select only perl versions where this expression returns true" },
      { name => "reverse|r", into => \$_reverse,
         description => "Reverses the order in which perl versions are invoked" },
      { name => "stop-on-fail|s", into => \$_stop_on_fail,
         description => "Stops running after the first failure" },
   );

   $self->maybe_apply_config( "./.eachperlrc" );
   $self->maybe_apply_config( "$ENV{HOME}/.eachperlrc" );
}

method maybe_apply_config ( $path )
{
   # Only accept files readable and owned by UID
   return unless -r $path;
   return unless -o _;

   my $config = Config::Tiny->read( $path );

   $_perls             //= $config->{_}{perls};
   $_since_version     //= $config->{_}{since_version};
   $_until_version     //= $config->{_}{until_version};
   $_only_if           //= $config->{_}{only_if};
   $_install_no_system //= $config->{_}{install_no_system};
}

method postprocess_config ()
{
   foreach ( $_since_version, $_until_version ) {
      defined $_ or next;
      m/^v/ or $_ = "v$_";
      # E.g. --until 5.14 means until the /end/ of the 5.14 series; so 5.14.999
      $_ .= ".999" if \$_ == \$_until_version and $_ !~ m/\.\d+\./;
      $_ = version->parse( $_ )->stringify;
   }

   if( my $perlnames = $_perls ) {
      foreach my $perl ( split m/\s+/, $perlnames ) {
         chomp( my $fullpath = `which $perl` );
         $? and warn( "Can't find perl at $perl" ), next;

         my ( $ver, $usethreads, $ccflags ) = split m/\n/,
            scalar `$fullpath -MConfig -e 'print "\$]\\n\$Config{usethreads}\\n\$Config{ccflags}\\n"'`;

         $ver = version->parse( $ver )->normal;
         my $threads = ( $usethreads eq "define" );
         my $debug = $ccflags =~ m/-DDEBUGGING\b/;
         my $devel = ( $ver =~ m/^v\d+\.(\d+)/ )[0] % 2;

         push @_perlobjs, App::eachperl::_Perl->new(
            name         => $perl,
            fullpath     => $fullpath,
            version      => $ver,
            is_threads   => $threads,
            is_debugging => $debug,
            is_devel     => $devel,
         );
      }
   }
}

method perls ()
{
   my @perls = @_perlobjs;
   @perls = reverse @perls if $_reverse;

   return map {
      my $perl = $_;
      my $ver = $perl->version;

      my $selected = 1;
      $selected = 0 if $_since_version and $ver lt $_since_version;
      $selected = 0 if $_until_version and $ver gt $_until_version;
      $selected = 0 if $_no_system_perl and $perl->fullpath eq $^X;
      $selected = 0 if defined $_use_devel and $perl->is_devel ^ $_use_devel;

      if( $selected and defined $_only_if ) {
         IPC::Run::run(
            [ $perl->fullpath, "-Mstrict", "-Mwarnings", "-MConfig",
               "-e", "exit !do {$_only_if}" ]
         ) == 0 and $selected = 0;
      }

      $perl->selected = $selected;

      $perl;
   } @perls;
}

method run ( @argv )
{
   my $cinv = Commandable::Invocation->new_from_tokens( @argv );

   $_finder->handle_global_options( $cinv );

   $self->postprocess_config;

   if( $cinv->peek_remaining =~ m/^-/ ) {
      $cinv->putback_tokens( "exec" );
   }

   return $_finder->find_and_invoke( $cinv );
}

method command_list
   :Command_description("List the available perls")
   ()
{
   foreach my $perl ( $self->perls ) {
      my @flags;
      push @flags, $perl->version;
      push @flags, "threads"   if $perl->is_threads;
      push @flags, "DEBUGGING" if $perl->is_debugging;
      push @flags, "devel"     if $perl->is_devel;

      printf "%s%s: %s (%s)\n",
         ( $perl->selected ? "* " : "  " ),
         $perl->name, $perl->fullpath, join( ",", @flags ),
      ;
   }
   return 0;
}

method exec ( @argv )
{
   my %opts = %{ shift @argv } if @argv and ref $argv[0] eq "HASH";

   my @results;
   my $ok = 1;

   my $signal;

   my @perls = $self->perls;
   my $idx = 0;
   foreach ( @perls ) {
      $idx++;
      next unless $_->selected;

      my $perl = $_->name;
      my $path = $_->fullpath;

      my @status = (
         ( $ok
            ? String::Tagged->new_tagged( "-OK-", fg => $COL{grey} )
            : String::Tagged->new_tagged( "FAIL", fg => $COL{red} ) ),

         String::Tagged->new
            ->append( "Running " )
            ->append_tagged( $perl, bold => 1 ),

         ( $idx < @perls
            ? String::Tagged->new_tagged( sprintf( "(%d more)", @perls - $idx ), fg => $COL{grey} )
            : () ),
      );

      $_io_term->set_status(
         String::Tagged->join( " | ", @status )
            ->apply_tag( 0, -1, bg => Convert::Color->new( "vga:blue" ) )
      );

      $opts{oneline}
         ? $_io_term->more_partial( "$BOLD$perl:$RESET " )
         : $_io_term->print_line( "\n$BOLD  --- $perl --- $RESET" );

      my $has_partial = $opts{oneline};
      IPC::Run::run [ $path, @argv ], ">pty>", sub {
         my @lines = split m/\r?\n/, $_[0], -1;

         if( $has_partial ) {
            my $line = shift @lines;

            if( $line =~ s/^\r// ) {