view release on metacpan or  search on metacpan

t/lib/MyTest/System.pm  view on Meta::CPAN

package MyTest::System;

use strict;
use warnings;
use Exporter qw( import );
use Scalar::Util qw( refaddr );
use Text::ParseWords qw( shellwords );
use Scalar::Util qw( weaken );
use File::Which ();

our @EXPORT = qw( system_fake system_add );

sub system_fake
{
  __PACKAGE__->new(@_);
}

my @stack;

*CORE::GLOBAL::system = sub {

  my $system = $stack[-1];

  if($system)
  {
    $system->call(@_);
  }
  else
  {
    return CORE::system(@_);
  }

};

{
  my $old = \&File::Which::which;
  no warnings 'redefine';
  *File::Which::which = sub
  {
    my $system = $stack[-1];

    if($system)
    {
      $system->can_run(@_);
    }
    else
    {
      return $old->(@_);
    }
  };
}

sub new
{
  my($class, %cmds) = @_;
  my $self = bless { %cmds }, $class;
  push @stack, $self;
  weaken $stack[-1];
  $self;
}

sub add
{
  my($self, $command, $code) = @_;
  $self->{$command} = $code;
}

sub call
{
  my($self, $command, @args) = @_;

  if(@args == 0)
  {
    if($^O eq 'MSWin32' && $command =~ /^"(.*)"$/)
    { $command = $1 }
    ($command, @args) = shellwords $command;
  }

  if($self->{$command})
  {
    my $exit = $self->{$command}->(@args);
    return $? = ($exit << 8);
  }
  else
  {
    $! = 'No such file or directory';
    return $? = -1;
  }
}

sub can_run
{
  my($self, $command) = @_;

  # we only really use can_run to figure out if
  # we CAN run an executable, but make up some
  # path just for pretends.
  $self->{$command}
  ? "/bin/$command"
  : undef;
}

sub DESTROY
{
  my($self) = @_;
  @stack = grep { refaddr($_) ne refaddr($self) } @stack;
}

1;