File Coverage

blib/lib/Test2/Tools/Process.pm

Criterion	Covered	Total	%
statement	263	287	91.6
branch	60	80	75.0
condition	27	38	71.0
subroutine	58	60	96.6
pod	5	6	83.3
total	413	471	87.6

package Test2::Tools::Process;

use strict;
use warnings;
use 5.010;
use Test2::Tools::Compare ();
use Test2::API qw( context );
use Ref::Util qw( is_plain_arrayref is_ref is_plain_coderef is_plain_hashref );
use Carp qw( croak carp );
use Test2::Compare::Array     ();
use Test2::Compare::Wildcard  ();
use Test2::Compare::Number    ();
use Test2::Compare::String    ();
use Test2::Compare::Custom    ();
use Test2::Compare ();
use Capture::Tiny qw( capture_stdout );
use base qw( Exporter );

our @EXPORT = qw( process proc_event named_signal intercept_exit intercept_exec );
our @CARP_NOT = qw( Test2::Tools::Process::SystemProc );

# ABSTRACT: Unit tests for code that calls exit, exec, system or qx()
our $VERSION = '0.05'; # VERSION


our %handlers;

BEGIN {

  %handlers = (
    exit     => sub (;$) { CORE::exit(@_) },
    exec     => sub      { CORE::exec(@_) },
    system   => sub      { CORE::system(@_) },
    readpipe => sub (_)  { CORE::readpipe(@_) },
  );

  no warnings 'redefine';
  *CORE::GLOBAL::exit     = sub (;$) { $handlers{exit}->(@_) };
  *CORE::GLOBAL::exec     = sub      { $handlers{exec}->(@_) };
  *CORE::GLOBAL::system   = sub      { $handlers{system}->(@_) };
  *CORE::GLOBAL::readpipe = sub (_)  { $handlers{readpipe}->(@_) };
}


sub process (&;@)
{
  my $sub = shift;
  my @expected  = ();
  my $test_name = 'process ok';
  my @events;
  my $i = 0;

  if(is_plain_arrayref $_[0])
  {
    @expected = @{ shift() };
  }

  $test_name = shift if defined $_[0];

  Test2::Tools::Process::ReturnMultiLevel::with_return(sub {
    my($return) = @_;

    local %handlers = %handlers;

    $handlers{exit} = sub {
      my $expected = $expected[$i++];

      my $status = shift;
      $status = 0 unless defined $status;
      $status = int($status);
      push @events, { event_type => 'exit', exit_status => $status };

      if(defined $expected && $expected->is_exit && defined $expected->callback)
      {
        my $proc = Test2::Tools::Process::Proc->new($return);
        my $ret = $expected->callback->($proc, $status);
        if(exists $proc->{errno})
        {
          $! = $proc->{errno};
          return 0;
        }
        return $ret;
      }
      else
      {
        $return->();
      }
    };

    $handlers{exec} = sub {
      my $expected = $expected[$i++];

      if(@_ == 1 || @_ == 0)
      {
        push @events, { event_type => 'exec', command => $_[0] };
      }
      else
      {
        push @events, { event_type => 'exec', command => [@_] };
      }

      if(defined $expected && $expected->is_exec && defined $expected->callback)
      {
        my $proc = Test2::Tools::Process::Proc->new($return);
        my $ret = $expected->callback->($proc, @_);
        if(exists $proc->{errno})
        {
          $! = $proc->{errno};
          return 0;
        }
        return $ret;
      }
      else
      {
        $return->();
      }
    };

    foreach my $type (qw( system readpipe ))
    {
      $handlers{$type} = sub {
        my $expected = $expected[$i++];

        my $event;
        my $args = \@_;
        if(@_ == 1 || @_ == 0)
        {
          push @events, $event = { event_type => 'system', command => $_[0] };
        }
        else
        {
          push @events, $event = { event_type => 'system', command => [@_] };
        }

        if(defined $expected && $expected->is_system && defined $expected->callback)
        {
          my $inner = sub {
            my($return) = @_;
            my $proc = Test2::Tools::Process::SystemProc->new($return, $event, $type);
            $expected->callback->($proc, @$args);
            $event->{status} = 0;
            $? = 0;
          };
          if($type eq 'system')
          {
            Test2::Tools::Process::ReturnMultiLevel::with_return($inner);
            return -1 if exists $event->{errno};
            return $?;
          }
          else
          {
            return scalar capture_stdout { Test2::Tools::Process::ReturnMultiLevel::with_return($inner) };
          }
        }
        else
        {
          local $SIG{__WARN__} = sub {
            my($message) = @_;
            $message =~ s/ at .*? line [0-9]+\.$//;
            chomp $message;
            carp($message);
          };
          my $ret = $type eq 'system' ? CORE::system(@_) : CORE::readpipe(@_);
          if($? == -1)
          {
            $event->{errno} = $!;
          }
          elsif($? & 127)
          {
            $event->{signal} = $? & 127;
          }
          else
          {
            $event->{status} = $? >> 8;
          }
          return $ret;
        }
      };
    }

    $sub->();
  });

  @_ = (
    \@events,
    [ map { $_->to_check } @expected ],
    $test_name
  );

  goto \&Test2::Tools::Compare::is;
}


{
  my $sig;
  sub named_signal ($)
  {
    my($name) = @_;

    # build hash on demand.
    $sig ||= do {
      require Config;
      my %sig;
      my @num = split /\s+/, $Config::Config{sig_num};
      foreach my $name (split /\s+/, $Config::Config{sig_name})
      {
        $sig{$name} = shift @num;
      }
      \%sig;
    };

    croak "no such signal: $name" unless exists $sig->{$name};

    $sig->{$name};
  }
}


sub intercept_exit (&)
{
  my $sub = shift;

  my $ret;

  Test2::Tools::Process::ReturnMultiLevel::with_return(sub {
    my $return = shift;
    local $handlers{exit} = sub {
      $ret = shift;
      $ret = 0 unless defined $ret;
      $ret = int $ret;
      $return->();
    };
    $sub->();
  });

  $ret;
}


sub intercept_exec (&)
{
  my $sub = shift;

  my $ret;

  Test2::Tools::Process::ReturnMultiLevel::with_return(sub {
    my $return = shift;
    local $handlers{exec} = sub {
      $ret = \@_;
      $return->();
    };
    $sub->();
  });

  $ret;
}


sub proc_event ($;$$$)
{
  my $type = shift;
  croak("no such process event undef") unless defined $type;

  my $check;
  my $check2;
  my $callback;

  $check  = shift if defined $_[0] && !is_plain_coderef $_[0] && !is_plain_hashref $_[0];
  $check2 = shift if defined $_[0] && is_plain_hashref $_[0];

  if(defined $_[0])
  {
    if(is_plain_coderef $_[0])
    {
      $callback = shift;
    }
    else
    {
      croak("callback is not a code reference");
    }
  }

  my @caller = caller;

  if($type eq 'exit')
  {
    if(defined $check)
    {
      unless(is_ref $check)
      {
        $check = Test2::Compare::Number->new(
          file => $caller[1],
          lines => [$caller[2]],
          input => $check,
        );
      }
    }
    else
    {
      $check = Test2::Compare::Custom->new(
        code     => sub { defined $_ ? 1 : 0 },
        name     => 'DEFINED',
        operator => 'DEFINED()',
        file => $caller[1],
        lines => [$caller[2]],
      );
    }

    return Test2::Tools::Process::Exit->new(status_check => $check, callback => $callback);
  }

  elsif($type =~ /^(exec|system)$/)
  {
    if(defined $check)
    {
      if(is_plain_arrayref $check)
      {
        my $array = Test2::Compare::Array->new(
          called => \@caller,
        );
        foreach my $item (@$check)
        {
          my $wc = Test2::Compare::Wildcard->new(
            expect => $item,
            file   => $caller[1],
            lines  => [$caller[2]],
          );
          $array->add_item($wc);
        }
        $check = $array;
      }
      elsif(!is_ref $check)
      {
        $check = Test2::Compare::String->new(
          file => $caller[1],
          lines => [$caller[2]],
          input => $check,
        );
      }
    }
    else
    {
      $check = Test2::Compare::Custom->new(
        code     => sub { defined $_ ? 1 : 0 },
        name     => 'DEFINED',
        operator => 'DEFINED()',
        file => $caller[1],
        lines => [$caller[2]],
      );
    }

    if($type eq 'system')
    {
      $check2 ||= { status => 0 };
    }

    my $class = $type eq 'exec'
      ? 'Test2::Tools::Process::Exec'
      : 'Test2::Tools::Process::System';
    return $class->new( command_check => $check, result_check => $check2, callback => $callback);
  }

  croak("no such process event $type");
}

package Test2::Tools::Process::Event;

use constant is_exit   => 0;
use constant is_exec   => 0;
use constant is_system => 0;
use Class::Tiny qw( callback );

package Test2::Tools::Process::Exit;

use constant is_exit => 1;
use base qw( Test2::Tools::Process::Event );
use Class::Tiny qw( status_check );

sub to_check
{
  my($self) = @_;
  { event_type => 'exit', exit_status => $self->status_check };
}

package Test2::Tools::Process::Exec;

use constant is_exec => 1;
use base qw( Test2::Tools::Process::Event );
use Class::Tiny qw( command_check );

sub to_check
{
  my($self) = @_;
  { event_type => 'exec', command => $self->command_check };
}

package Test2::Tools::Process::System;

use constant is_system => 1;
use base qw( Test2::Tools::Process::Event );
use Class::Tiny qw( command_check result_check );

sub to_check
{
  my($self) = @_;
  { event_type => 'system', command => $self->command_check, %{ $self->result_check } };
}

package Test2::Tools::Process::Proc;

sub new
{
  my($class, $return) = @_;
  bless {
    return => $return,
  }, $class;
}

sub terminate { shift->{return}->() }

sub errno
{
  my($self, $errno) = @_;
  $self->{errno} = $errno;
}

package Test2::Tools::Process::SystemProc;

sub new
{
  my($class, $return, $result, $type) = @_;
  bless {
    return => $return,
    result => $result,
    type   => $type,
  }, $class;
}

sub type { shift->{type} }

sub exit
{
  my($self, $status) = @_;
  $status = 0 unless defined $status;
  $status = int $status;
  $self->{result}->{status} = $status;
  $? = $status << 8;
  $self->{return}->();
}

sub signal
{
  my($self, $signal) = @_;
  $signal = 0 unless defined $signal;
  if($signal =~ /^[A-Z]/i)
  {
    $signal = Test2::Tools::Process::named_signal($signal);
  }
  else
  {
    $signal = int $signal;
  }
  $self->{result}->{signal} = $signal;
  $? = $signal;
  $self->{return}->();
}

sub errno
{
  my($self, $errno) = @_;
  $errno = 0 unless defined $errno;
  $errno = int $errno;
  $self->{result}->{errno} = $! = $errno;
  $self->{return}->();
}

package Test2::Tools::Process::ReturnMultiLevel;

# this is forked from Return::MultiLevel (XS implementation only)
# we can remove this when it gets a maintainer again.

use Scope::Upper;
use Carp ();
use base qw( Exporter );
our @EXPORT_OK = qw( with_return );

$INC{'Test2/Tools/Process/ReturnMultiLevel.pm'} = __FILE__;

sub with_return (&)
{
  my ($f) = @_;
  my $ctx = Scope::Upper::HERE();
  my @canary =
    !$ENV{RETURN_MULTILEVEL_DEBUG}
        ? '-'
        : Carp::longmess "Original call to with_return"
  ;

  local $canary[0];
  $f->(sub {
    $canary[0]
      and confess
        $canary[0] eq '-'
          ? ""
          : "Captured stack:\n$canary[0]\n",
        "Attempt to re-enter dead call frame"
      ;
      Scope::Upper::unwind(@_, $ctx);
  })
}

1;

__END__