TAP::Harness::Remote - Run tests on a remote server farm

    prove -l --state=save,slow --harness TAP::Harness::Remote t/*.t

    ---
    ssh: /usr/bin/ssh
    local:
      - /path/to/local/testing/root/
      - /path/to/another/testing/root/
    user: username
    host: remote.testing.host.example.com
    root: /where/to/place/local/root/on/remote/
    perl: /usr/bin/perl
    master: 1
    ssh_args:
      - -x
      - -S
      - '~/.ssh/master-%r@%h:%p'
    rsync_args:
      - -C
      - --exclude
      - blib
    env:
      FOO: bar

    prove -l --harness TAP::Harness::Remote t/*.t

package TAP::Harness::Remote;

our $VERSION = '1.10';

use warnings;
use strict;
use Carp;

use base 'TAP::Harness';
use constant config_path => "$ENV{HOME}/.remote_test";
use File::Spec;
use Cwd;
use YAML;

sub new {
    my $class = shift;
    my $self  = $class->SUPER::new(@_);

    $self->load_remote_config;
    for ( @{$self->remote_config("local")} ) {
        die
            "Local testing root ($_) doesn't exist\n"
            unless -d $_;
    }

    # Find which testing root we're under

    die
        "Current path isn't inside of local testing roots (@{$self->remote_config('local')})\n"
        unless defined $self->rewrite_path( Cwd::cwd );

    die "Testing host not defined\n"
        unless grep { defined and not /\.example\.com$/ }
        @{ $self->remote_config("host") };

    die
        "Can't find or execute ssh command: @{[$self->remote_config('ssh')]}\n"
        unless -e $self->remote_config("ssh")
        and -x $self->remote_config("ssh");

    $ENV{HARNESS_PERL} = $self->remote_config("ssh");

    $self->jobs( $self->jobs * @{ $self->remote_config("host") } );

    $self->callback( before_runtests => sub { $self->setup(@_) } );
    $self->callback( parser_args     => sub { $self->change_switches(@_) } );
    return $self;
}

sub default_config {
    return {
        user       => "smoker",
        host       => "smoke-server.example.com",
        root       => "/home/smoker/remote-test/$ENV{USER}/",
        perl       => "/home/smoker/bin/perl",
        local      => [ "$ENV{HOME}/remote-test/" ],
        ssh        => "/usr/bin/ssh",
        ssh_args   => [ "-x", "-S", "~/.ssh/master-%r@%h:%p" ],
        rsync_args => [ "-C" ],
        master     => 1,
        env        => {},
    };
}

sub load_remote_config {
    my $self = shift;
    unless ( -e $self->config_path and -r $self->config_path ) {
        YAML::DumpFile( $self->config_path, $self->default_config );
    }
    $self->{remote_config} = YAML::LoadFile( $self->config_path );

    # Make local path into an arrayref
    $self->{remote_config}{local} = [ $self->{remote_config}{local} ]
      unless ref $self->{remote_config}{local};

    # Strip trailing slashes in local dirs, for rsync
    $self->{remote_config}{local} = [map {s|/$||; $_} @{$self->{remote_config}{local}}];

    # Host should be an arrayref
    $self->{remote_config}{host} = [ $self->{remote_config}{host} ]
        unless ref $self->{remote_config}{host};

    # Ditto ssh_args
    $self->{remote_config}{ssh_args}
        = [ split ' ', ( $self->{remote_config}{ssh_args} || "") ]
        unless ref $self->{remote_config}{ssh_args};

    # Also, rsync_args
    $self->{remote_config}{rsync_args}
        = [ split ' ', ($self->{remote_config}{rsync_args} || "") ]
        unless ref $self->{remote_config}{rsync_args};

    # Defaults for env
    $self->{env} ||= {};
}

sub remote_config {
    my $self = shift;
    $self->load_remote_config unless $self->{remote_config};
    return $self->{remote_config}->{ shift @_ };
}

sub userhost {
    my $self = shift;
    my $userhost = @_ ? shift : $self->remote_config("host")->[0];
    $userhost = $self->remote_config("user") . "\@" . $userhost
        if $self->remote_config("user");
    return $userhost;
}

sub start_masters {
    my $self = shift;
    return unless $self->remote_config("master");

    local $SIG{USR1} = sub {
        die "Failed to set up SSH master connections\n";
    };

    my $parent = $$;
    for my $host ( @{ $self->remote_config("host") } ) {
        my $userhost = $self->userhost($host);
        my $pid      = fork;
        die "Fork failed: $!" unless $pid >= 0;
        if ( not $pid ) {
            # Make sure we clean out this list, so we don't run
            # anything on _our_ DESTROY
            $self->{ssh_master} = {};

            # Start the master
            system($self->remote_config("ssh"),
                @{ $self->remote_config("ssh_args") }, "-M", "-N", $userhost);

            # Signal the parent when we're done; we're still within 2
            # seconds of starting, we'll catch this and abort.
            kill 'USR1', $parent;
            exit;
        }
        $self->{ssh_master}{$userhost} = $pid;
    }

    # During this sleep, we're waiting for our kids to tell us that
    # they died.
    sleep 5;
}

sub setup {
    my $self = shift;
    $SIG{USR1} = sub {};
    $self->start_masters;
    $self->rsync;

    # Set up our perl5lib
    $self->{perl5lib} = join( ":", grep {defined} map {$self->rewrite_path($_)} split( /:/, $ENV{PERL5LIB} || "" ) );
    $self->{perl5lib} =~ s/^(lib:){1,}/lib:/;

    # Also, any other env vars
    $self->{env} = [];
    for my $k (keys %{$self->remote_config("env")}) {
        my $val = $self->remote_config("env")->{$k};
        $val =~ s/'/'"'"'/g;
        push @{$self->{env}}, "$k='$val'";
    }
}

sub rsync {
    my $self = shift;

    for my $host ( @{ $self->remote_config("host") } ) {
        my $userhost = $self->userhost($host);
        my $return   = system(
            qw!rsync -avz --delete!,
            @{$self->remote_config('rsync_args')},
            qq!--rsh!,
            $self->remote_config("ssh")
                . " @{$self->remote_config('ssh_args')}",
            @{$self->remote_config("local")},
            "$userhost:" . $self->remote_config("root")
        );
        die "rsync to $userhost failed" if $return;
    }
}

sub rewrite_path {
    my $self = shift;
    my $path = shift;
    my $remote = $self->remote_config("root");
    for my $local ( @{$self->remote_config("local")} ) {
        if ($path =~ /^$local/) {
            $path =~ s{^$local}{$remote . "/" . (File::Spec->splitpath($local))[-1]}e;
            return $path;
        }
    }
    return undef;
}

sub DESTROY {
    my $self = shift;
    return unless $self->remote_config("master");
    for my $userhost ( keys %{ $self->{ssh_master} || {} } ) {
        next unless kill 0, $self->{ssh_master}{$userhost};
        system $self->remote_config("ssh"), @{ $self->remote_config("ssh_args") }, "-O",
            "exit", $userhost;
    }
}

sub change_switches {
    my ( $self, $args, $test ) = @_;

    my $remote = $self->remote_config("root");

    my @other = grep { not /^-I/ } @{ $args->{switches} };
    my @inc = map {"-I$_"} grep {defined $_} map { s/^-I//; $self->rewrite_path($_) }
        grep {/^-I/} @{ $args->{switches} };

    my $host = $self->remote_config("host")
        ->[ $self->{hostno}++ % @{ $self->remote_config("host") } ];
    my $userhost = $self->userhost($host);
    $args->{switches} = [
        @{ $self->remote_config("ssh_args") }, $userhost,
        "cd",                                  $self->rewrite_path( Cwd::cwd ),
        "&&",                                  "PERL5LIB='@{[$self->{perl5lib}]}'",
        @{$self->{env}},
        $self->remote_config("perl"),          @other,
        @inc
    ];
}

1;