view release on metacpan or  search on metacpan

lib/App/Prove/Plugin/Distributed.pm  view on Meta::CPAN

=head1 SYNOPSIS

  # All of the examples below is loading tests into the worker perl processes
  # If you want to run the tests in a separate perl process, you can specify
  # the '--detach' option to accomplish that.
  
  # Default workers with L<IPC::Open3> as worker processes.
  prove -PDistributed -j2 t/

  # Distributed jobs with LSF workers.
  prove -PDistributed --distributed-type=LSF -j2 t/

  # Distributed jobs with SSH workers.
  prove -PDistributed --distributed-type=SSH -j2 --hosts=host1,host2 t/

  # If you are using home network that does not have name server setup,
  # you can specify the option --use-local-public-ip
  prove -PDistributed --distributed-type=SSH --use-local-public-ip -j2 --hosts=host1,host2 t/
  
  # Distributed jobs with PBS workers using L<PBS::Client>. Note: This is not tested yet.
  prove -PDistributed --distributed-type=PBS -j2 t/

  # Distributed jobs with PBS workers using L<PBS::Client>. Note: This is not tested yet.
  # With PBS option
  prove -PDistributed --distributed-type=PBS --mem=200 -j2 t/

=head1 DESCRIPTION

A plugin for App::Prove to distribute job.  The core implementation of the plugin is to
provide a easy interface and functionality to extend the use of any distribution method.

The initiate release of this module was using the idea from L<FCGI::Daemon> that load perl
code file using "do" perl function to the worker perl process to execute tests.

Currently, the distribution comes with a few implementation of distribution methods to
initiate external "worker" processes.
Shown below is the list.
   
   L<IPC::Open3>
   LSF 
   SSH
   L<PBS::Client>  * Note: PBS implemetation is not tested yet.

=head1 FUNCTIONS

Basic functions.

=head3 C<load>

Load the plugin configuration.
It will setup all of the tests to be distributed through the 
L<TAP::Parser::SourceHandler::Worker> source handler class.

=cut

sub load {
    my ( $class, $p ) = @_;
    my @args = @{ $p->{args} };
    my $app  = $p->{app_prove};
    {
        local @ARGV = @args;

        push @ARGV, grep { /^--/ } @{ $app->{argv} };
        $app->{argv} = [ grep { !/^--/ } @{ $app->{argv} } ];
        Getopt::Long::Configure(qw(no_ignore_case bundling pass_through));

        # Don't add coderefs to GetOptions
        GetOptions(
            'manager=s'          => \$app->{manager},
            'distributed-type=s' => \$app->{distributed_type},
            'start-up=s'         => \$app->{start_up},
            'tear-down=s'        => \$app->{tear_down},
            'error-log=s'        => \$app->{error_log},
            'detach'             => \$app->{detach},
            'sync-type=s'        => \$app->{sync_type},
            'source-dir=s'       => \$app->{source_dir},
            'destination-dir=s'  => \$app->{destination_dir},
        ) or croak('Unable to continue');

#LSF: We pass the option to the source handler if the source handler want the options.
        unless ( $app->{manager} ) {
            my $source_handler_class =
                'TAP::Parser::SourceHandler::' 
              . 'Worker'
              . (
                $app->{distributed_type}
                ? '::' . $app->{distributed_type}
                : ''
              );
            eval "use $source_handler_class";
            unless ($@) {
                unless ( $source_handler_class->load_options( $app, \@ARGV ) ) {
                    croak('Unable to continue without needed worker options.');
                }
            }
        }

    }
    my $type = $app->{distributed_type};
    my $option_name = '--worker' . ( $type ? '-' . lc($type) : '' ) . '-option';
    if (   $app->{argv}->[0]
        && $app->{argv}->[0] =~ /$option_name=number_of_workers=(\d+)/ )
    {
        if ( $app->{jobs} ) {
            die
              "-j and $option_name=number_of_workers are mutually exclusive.\n";
        }
        else {
            $app->{jobs} = $1;
        }
    }
    else {
        $app->{jobs} ||= 1;
        unshift @{ $app->{argv} },
          "$option_name=number_of_workers=" . $app->{jobs};
    }

    for (
        qw(start_up tear_down error_log detach sync_type source_dir destination_dir)
      )
    {

lib/App/Prove/Plugin/Distributed.pm  view on Meta::CPAN

                : $socket->sockhost
              )
              . ':'
              . $socket->sockport;
            print $socket (
                '# ',
                ( join "\n# ", ( "Worker: <$spec>", ( split /\n/, $error ) ) ),
                "\n"
            );
            if ($error_log) {
                use IO::File;
                my $fh = IO::File->new( "$error_log", 'a+' );
                unless ( flock( $fh, LOCK_EX | LOCK_NB ) ) {
                    warn "can't immediately write-lock ",
                      "the file ($!), blocking ...";
                    unless ( flock( $fh, LOCK_EX ) ) {
                        die "can't get write-lock on numfile: $!";
                    }
                }
                print $fh (
                    join "\n",
                    (
                        "<< START $job_info >>",
                        "SERVER: $server_spec",
                        "PID: $$",
                        "ERROR: $error",
                        "<< END $job_info >>"
                    )
                );
                close $fh;
            }
        }

        #LSF: How to exit with END block trigger.
        &trigger_end_blocks_before_child_process_exit();

        #LSF: Might not need this.
        $socket->flush;
        exit(0);
    }
    else {
        die "should not get here.\n";
    }
    $socket->close();
    return 1;
}

sub _do {
    my $proto    = shift;
    my $job_info = shift;
    my $args     = shift;
    my $cwd      = File::Spec->rel2abs('.');

    #LSF: The code from here to exit is from  L<FCGI::Daemon> module.
    local *CORE::GLOBAL::exit = sub { die 'notr3a11yeXit' };
    local $0 = $job_info;    #fixes FindBin (in English $0 means $PROGRAM_NAME)
    no strict;               # default for Perl5
    {

        package main;
        local @ARGV = $args ? @$args : ();
        do $0;               # do $0; could be enough for strict scripts
        chdir($cwd);

        if ($EVAL_ERROR) {
            $EVAL_ERROR =~ s{\n+\z}{};
            unless ( $EVAL_ERROR =~ m{^notr3a11yeXit} ) {
                $error = $EVAL_ERROR;
                return;
            }
        }
        elsif ($@) {
            $error = $@;
            return;
        }
    }
    return 1;
}

=head3 C<trigger_end_blocks_before_child_process_exit>

Trigger END blocks before the child process exit.
The main reason is to have the Test::Builder to have
change to finish up.

=cut

sub trigger_end_blocks_before_child_process_exit {
    my $original_pid;
    if ( $Test::Builder::Test && $Test::Builder::Test->{Original_Pid} != $$ ) {
        $original_pid = $Test::Builder::Test->{Original_Pid};
        $Test::Builder::Test->{Original_Pid} = $$;
    }
    use B;
    my @ENDS = B::end_av->ARRAY;
    for my $END (@ENDS) {
        $END->object_2svref->();
    }
    if ( $Test::Builder::Test && $original_pid ) {
        $Test::Builder::Test->{Original_Pid} = $original_pid;
    }
}

=head3 C<rsync_test_env>

Rsync test enviroment to the worker host.

Parameters $app object
Returns boolean

=cut

sub rsync_test_env {
    my $proto   = shift;
    my $app     = shift;
    my $manager = $app->{manager};

    my ( $host, $port ) = split /:/, $manager, 2;
    my $dest = $app->{destination_dir};
    unless ($dest) {
        require File::Temp;