view release on metacpan or  search on metacpan

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

package App::ppll v0.0.1;      ## no critic [NamingConventions::Capitalization]

=encoding utf8

=head1 NAME

App::ppll - Command runner

=head1 VERSION

0.0.1

=head1 DESCRIPTION

C<ppll> is a tool to control the execution of commands. It can run commands in
parallel, construct commands from lists of parameters, and more.

It handles the output of commands and can prefix lines with which command
produced it, print timestamps, etc.

C<ppll> has functionality similar to C<xargs> and C<parallel>.

This page documents C<ppll>’s Perl API. For user documentation of the C<ppll>
command see L<ppll|ppll>.

=head1 SYNOPSIS

    my $ppll = App::ppll->new( %args );
    $ppll->call();

=cut

use autodie;
use strict;
use utf8::all;
use v5.20;
use warnings;

use Carp;
use DateTime;
use Digest::MD5 qw( md5 );
use English qw( -no_match_vars );
use Getopt::Long;
use List::Flatten qw( flat );
use List::Util qw( max shuffle );
use POSIX qw( isatty );
use Pod::Usage qw( pod2usage );
use Readonly;
use String::ShellQuote qw( shell_quote );
use Sys::CPU qw( cpu_count );
use Term::ANSIColor qw( colored );
use Term::ReadKey;
use Time::Duration qw( concise duration );
use Time::HiRes qw( time );

use experimental 'signatures';

require App::ppll::Worker;

Readonly my @COLOURS => (

  'white on_black',
  'black on_red',
  'black on_green',
  'black on_yellow',
  'white on_blue',
  'black on_magenta',
  'black on_cyan',
  'black on_white',
  'white on_bright_black',
  'black on_bright_red',
  'black on_bright_green',
  'black on_bright_yellow',
  'black on_bright_blue',
  'black on_bright_magenta',
  'black on_bright_cyan',
  'black on_bright_white',

);

Readonly my @MODES => ( qw(
    auto
    fields
    lines
    slpf
    ) );

Readonly my $WIDTH => 80;

=head1 SUBROUTINES/METHODS

=head2 C<call>

Runs C<ppll>.

Returns an integer suitable for C<exit> (0 if everything went fine, non-0
otherwise).

=cut

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

  for my $worker ( @{ $self->{pool} } ) {
    $worker->stop;
  }

  return;
}

sub _coloured ( $self, $str, @args ) {
  return $str
    unless $self->{colour};

  return colored( $str, @args );
}

sub _make_argv ( $self, $parameter ) {
  my @argv = @{ $self->{cmd} };

  return @argv
    unless defined $parameter;

  my $replstr = $self->{replstr} // '{}';

  return ( @argv, $parameter )
    unless scalar grep {m/\Q$replstr\E/} @argv;

  return map {s/\Q$replstr\E/$parameter/gr} @argv;
}

sub _parse_sequence ( $self, $str ) {
  my @seq;

  for my $part ( split( /,/, $str ) ) {
    $part =~ m/^(?:(.*)\.\.)?(.*)$/
      or croak sprintf( 'Bad sequence specifier ‘%s’', $part );

    my $beg = $1 // '1';
    my $end = $2;

    my $w = max( map {length} ( $beg, $end ) );
    push @seq,
      sprintf( '%0*s', $w, $beg ) lt sprintf( '%0*s', $w, $end )
      ? $beg .. $end
      : reverse $end .. $beg;
  }

  return wantarray ? @seq : \@seq;
}

sub _printer ( $self, $prefix, $marker, $dest ) {
  binmode $dest, ':encoding(UTF-8)';
  $dest->autoflush( 1 );

  my @subs;

  push @subs, sub {$prefix}
    if defined $prefix
    and $self->{prefix};

  push @subs, sub {
    $self->_coloured(
      DateTime->from_epoch(
        epoch     => time,
        time_zone => 'local',
      )->strftime( $self->{timestamp_format} ),
      'reverse faint',
    );
    }
    if $self->{timestamp_format};

  push @subs, sub { $self->_coloured( $marker, 'faint' ) }
    if $self->{markers};

  push @subs, sub {' '}
    if @subs;

  return sub {
    for ( @_ ) {
      chomp;
      say {$dest} join( '', map { $_->() } @subs ) . $_;
    }
    return;
  };
} ## end sub _printer

sub _ps_four() {
  state $ps_four;

  unless ( defined $ps_four ) {
    $ps_four = $ENV{PS4};
    utf8::decode(              ## no critic [Subroutines::ProhibitCallsToUnexportedSubs]
      $ps_four,
    ) if $ps_four;
    $ps_four //= '+ ';
  }

  return $ps_four;
}

sub _push_parameters ( $self, @parameters ) {
  $self->{parameters} //= [ [] ];

  @parameters = grep {m/./} @parameters
    unless $self->{empty};

  confess unless $self->{parameters};

  push @{ $self->{parameters}->[-1] }, @parameters;

  return;
}

sub _split_fields ( $self, $str ) {
  return split( $self->{delimiter}, $str );
}

sub _string_colour( $str ) {
  return $COLOURS[ unpack( 'L', substr( md5( $str ), 0, 2 * 2 ) ) %
    scalar @COLOURS ];
}

sub _width( $self ) {