File Coverage

blib/lib/Test/Script/Async.pm

Criterion	Covered	Total	%
statement	199	213	93.4
branch	56	68	82.3
condition	17	27	62.9
subroutine	35	37	94.5
pod	17	17	100.0
total	324	362	89.5

package Test::Script::Async;

use strict;
use warnings;
use 5.008001;
use Carp ();
use AnyEvent::Open3::Simple 0.86;
use File::Spec ();
use Probe::Perl;
use Test2::API qw( context );
use base qw( Exporter );

# ABSTRACT: Non-blocking friendly tests for scripts
our $VERSION = '0.02'; # VERSION

our @EXPORT    = qw( script_compiles script_runs );


sub _path ($)
{
  my $path = shift;
  Carp::croak("Did not provide a script name") unless $path;
  Carp::croak("Script name must be relative") if File::Spec::Unix->file_name_is_absolute($path);
  File::Spec->catfile(
    File::Spec->curdir,
    split /\//, $path
  );
}

my $perl;

sub _perl ()
{
  $perl ||= Probe::Perl->find_perl_interpreter;
}

sub _detect
{
  if(grep /^(Mojo|Mojolicious)(\/.*)?\.pm?$/, keys %INC)
  { 'mojo' }
  else
  { return undef }
}

sub _is_mojo
{
  my $detect = _detect();
  defined $detect && $detect eq 'mojo';
}


sub script_compiles
{
  my($script, $test_name) = @_;
  my @libs = map { "-I$_" } grep { !ref($_) } @INC;
  my @cmd = ( _perl, @libs, '-c', _path $script );

  $test_name ||= "Script $script compiles";

  # TODO: also work with mojo
  my $done;
  unless(_detect())
  {
    require AE;
    $done = AE::cv();
  }
  my @stderr;

  my $ctx = context();

  my $ipc = AnyEvent::Open3::Simple->new(
    on_stderr => sub {
      my($proc, $line) = @_;
      push @stderr, $line;
    },
    on_exit   => sub {
      my($proc, $exit, $sig) = @_;

      my $ok = $exit == 0 && $sig == 0 && grep / syntax OK$/, @stderr;

      $ctx->send_event('Ok', pass => $ok, name => $test_name);
      $ctx->diag(@stderr) unless $ok;
      $ctx->diag("exit - $exit") if $exit;
      $ctx->diag("signal - $sig") if $sig;

      $done->send($ok);

    },
    on_error  => sub {
      my($error) = @_;

      $ctx->send_event('Ok', pass => 0, name => $test_name);
      $ctx->diag("error compiling script: $error");

      $done->send(0);
    },
  );

  $ipc->run(@cmd);
  my $ok = $done->recv;
  $ctx->release;

  $ok;
}


# TODO: support stdin input

sub script_runs
{
  my($script, $test_name) = @_;
  my @libs = map { "-I$_" } grep { !ref($_) } @INC;
  $script = [ $script ] unless ref $script;
  my @args;
  ($script, @args) = @$script;
  my @cmd = ( _perl, @libs, _path $script, @args );

  $test_name ||= @args ? "Script $script runs with arguments @args" : "Script $script runs";

  # TODO: also work with mojo
  my $done;
  unless(_detect())
  {
    require AE;
    $done = AE::cv();
  }
  my $run = bless {
    script => _path $script,
    args   => [@args],
    out    => [],
    err    => [],
    ok     => 0,
  }, __PACKAGE__;
  my $ctx = context();

  unless(-f $script)
  {
    $ctx->send_event('Ok', pass => 0, name => $test_name);
    $ctx->diag("script does not exist");
    $run->{fail} = 'script not found';
    $ctx->release;
    return $run;
  }

  my $ipc = AnyEvent::Open3::Simple->new(
    implementation => _detect(),
    on_stderr => sub {
      my(undef, $line) = @_;
      push @{ $run->{err} }, $line;
    },
    on_stdout => sub {
      my(undef, $line) = @_;
      push @{ $run->{out} }, $line;
    },
    on_exit   => sub {
      (undef, $run->{exit}, $run->{signal}) = @_;

      $run->{ok} = 1;
      $ctx->send_event('Ok', pass => 1, name => $test_name);

      _is_mojo() ? $done = 1 : $done->send;

    },
    on_error  => sub {
      my($error) = @_;

      $run->{ok} = 0;
      $run->{fail} = $error;
      $ctx->send_event('Ok', pass => 0, name => $test_name);
      $ctx->diag("error running script: $error");
      _is_mojo() ? $done = 1 : $done->send;
    },
  );

  $ipc->run(@cmd);
  if(_is_mojo())
  {
    Mojo::IOLoop->one_tick until $done;
  }
  else
  {
    $done->recv;
  }
  $ctx->release;

  $run;
}


sub out { shift->{out} }
sub err { shift->{err} }
sub exit { shift->{exit} }
sub signal { shift->{signal} }


our $reverse = 0;
our $level   = 0;

sub exit_is
{
  my($self, $value, $test_name) = @_;
  my $ctx = context( level => $level );

  $test_name ||= $reverse ? "script exited with a value other than $value" : "script exited with value $value";
  my $ok = defined $self->exit && !$self->{signal} && ($reverse ? $self->exit != $value : $self->exit == $value);

  $ctx->send_event('Ok', pass => $ok, name => $test_name);
  if(!defined $self->exit)
  {
    $ctx->diag("script did not run so did not exit");
  }
  elsif($self->signal)
  {
    $ctx->diag("script killed with signal @{[ $self->signal ]}");
  }
  elsif(!$ok)
  {
    $ctx->diag("script exited with value @{[ $self->exit ]}");
  }

  $self->{ok} = 0 unless $ok;

  $ctx->release;
  $self;
}


sub exit_isnt
{
  local $reverse = 1;
  local $level   = 1;
  shift->exit_is(@_);
}


sub signal_is
{
  my($self, $value, $test_name) = @_;
  my $ctx = context(level => $level);

  $test_name ||= $reverse ? "script not killed by signal $value" : "script killed by signal $value";
  my $ok = $self->signal && ($reverse ? $self->signal != $value : $self->signal == $value);

  $ctx->send_event('Ok', pass => $ok, name => $test_name);
  if(!defined $self->signal)
  {
    $ctx->diag("script did not run so was not killed");
  }
  elsif(!$self->signal)
  {
    $ctx->diag("script exited with value @{[ $self->exit ]}");
  }
  elsif(!$ok)
  {
    $ctx->diag("script killed with signal @{[ $self->signal ]}");
  }

  $self->{ok} = 0 unless $ok;

  $ctx->release;
  $self;
}


sub signal_isnt
{
  local $reverse = 1;
  local $level   = 1;
  shift->signal_is(@_);
}


our $stream = 'out';
our $stream_name = 'standard output';

sub out_like
{
  my($self, $regex, $test_name) = @_;

  my $ctx = context(level => $level);
  $test_name ||= $reverse ? "$stream_name does not match $regex" : "$stream_name matches $regex";

  my $ok;
  my @diag;

  if($reverse)
  {
    $ok = 1;
    my $num = 1;
    foreach my $line (@{ $self->{$stream} })
    {
      if($line =~ $regex)
      {
        $ok = 0;
        push @diag, "line $num of $stream_name matches: $line";
      }
      $num++;
    }
  }
  else
  {
    $ok = 0;
    foreach my $line (@{ $self->{$stream} })
    {
      if($line =~ $regex)
      {
        $ok = 1;
        last;
      }
    }
  }

  $ctx->send_event('Ok', pass => $ok, name => $test_name);
  $ctx->diag($_) for @diag;

  $ctx->release;
  $self->{ok} = 0 unless $ok;

  $self;
}


sub out_unlike
{
  local $reverse = 1;
  local $level   = 1;
  shift->out_like(@_);
}


sub err_like
{
  local $stream      = 'err';
  local $stream_name = 'standard error';
  local $level       = 1;
  shift->out_like(@_);
}


sub err_unlike
{
  local $stream      = 'err';
  local $stream_name = 'standard error';
  local $reverse     = 1;
  local $level       = 1;
  shift->out_like(@_);
}


our $diag = 'diag';

sub diag
{
  my($self) = @_;

  my $ctx = context(level => $level);

  $ctx->$diag("script:    @{[ $self->{script} ]}");
  $ctx->$diag("arguments: @{[ join ' ', @{ $self->{args} } ]}") if @{ $self->{args} };
  if(defined $self->{fail})
  {
    $ctx->$diag("error:     @{[ $self->{fail} ]}");
  }
  elsif($self->signal)
  {
    $ctx->$diag("signal:    @{[ $self->signal ]}");
  }
  else
  {
    $ctx->$diag("exit:      @{[ $self->exit ]}");
  }
  $ctx->$diag("[out] $_") for @{ $self->out };
  $ctx->$diag("[err] $_") for @{ $self->err };

  $ctx->release;

  $self;
}


sub note
{
  local $diag  = 'note';
  local $level = 1;
  shift->diag;
}


sub diag_if_fail
{
  my($self) = @_;
  return if $self->{ok};
  local $level = 1;
  $self->diag;
  $self;
}

1;

__END__