File Coverage

blib/lib/Test/Mock/ExternalCommand.pm

Criterion	Covered	Total	%
statement	89	91	97.8
branch	7	10	70.0
condition			n/a
subroutine	23	23	100.0
pod	6	6	100.0
total	125	130	96.1

package Test::Mock::ExternalCommand;
use strict;
use warnings;
use Config;
use Carp;
use Variable::Expand::AnyLevel qw(expand_variable);

use 5.010;
our $VERSION = '0.03';

my $command_registry = {};
my $command_history = {};

BEGIN {
    sub _command_and_args {
        my ( $command, @args ) = @_;
        my ( $command_real, @args2 ) = split qr/\s+/, $command;
        my @args_real = (@args2, @args);
        return ($command_real, @args_real);
    }

    *CORE::GLOBAL::system = sub {
        my ( $command, @args ) = _command_and_args(@_);
        if ( defined $command_registry->{$command} ) {
            return $command_registry->{$command}->{system}->(@args);
        }
        CORE::system(@_);
    };

    *CORE::GLOBAL::readpipe = sub {
        # readpipe receives variable name if variable is used in backquote string ...
        # so it is need to expand using Variable::Expand::AnyLevel::expand_variable
        my @new_args = map { expand_variable($_, 1) } @_;
        my ( $command, @command_args ) = _command_and_args(@new_args);
        if ( defined $command_registry->{$command} ) {
            return $command_registry->{$command}->{readpipe}->(@command_args);
        }
        CORE::readpipe(@_);
    };
}


=head1 NAME

Test::Mock::ExternalCommand - Create mock external-command easily

=head1 SYNOPSIS

  use Test::Mock::ExternalCommand;
  my $m = Test::Mock::ExternalCommand->new();
  $m->set_command( 'my-command-aaa', 'command-output', 0);
  # use 'my-command-aaa' in your test.

=head1 DESCRIPTION

Test::Mock::ExternalCommand enable to make mock-external command in easy way.

=head1 Methods

=cut

=head2 new()

=cut

sub new {
    my ( $class ) = @_;
    my $self = {
        my_commands     => {},
    };
    bless $self, $class;
    my $address = $self + 0;
    $command_history->{$address} = [];
    return $self;
}

=head2 set_command( $command_name,  $command_output_string, $command_exit_status )

set mock external command command.

=cut

sub set_command {
    my ( $self, $command_name, $command_output, $command_exit_status ) = @_;

    carp "${command_name}: already defined\n" if ( defined $command_registry->{$command_name} );
    $self->{my_commands}->{$command_name} = $command_name;

    my $address = $self + 0; # address is calculated in this scope avoiding refcount increment

    $command_registry->{$command_name}->{system} = sub {
        my ( @args ) = @_;
        push @{ $command_history->{$address} }, [$command_name, @args];
        print $command_output;
        return $command_exit_status << 8;
    };

    $command_registry->{$command_name}->{readpipe} = sub {
        my ( @args ) = @_;
        push @{ $command_history->{$address} }, [$command_name, @args];
        return $command_output;
    };
}

=head2 set_command_by_coderef( $command_name,  $command_behavior_subref )

set mock external command command using subroutine reference(coderef).

=cut

sub set_command_by_coderef {
    my ( $self, $command_name, $command_behavior_subref ) = @_;

    carp "${command_name}: already defined\n" if ( defined $command_registry->{$command_name} );
    $self->{my_commands}->{$command_name} = $command_name;

    my $address = $self + 0; # address is calculated in this scope avoiding refcount increment

    $command_registry->{$command_name}->{system} = sub {
        my ( @args ) = @_;
        push @{ $command_history->{$address} }, [$command_name, @args];
        my $ret =  $command_behavior_subref->(@args);
        return $ret << 8;
    };
    $command_registry->{$command_name}->{readpipe} = sub {
        my ( @args ) = @_;
        push @{ $command_history->{$address} }, [$command_name, @args];
        return $command_behavior_subref->(@args);
    };
}

=head2 history()

return command history.

=cut

sub history {
    my ( $self ) = @_;
    my $address = $self + 0;
    return @{ $command_history->{$address} };
}

=head2 reset_history()

reset command history.

=cut

sub reset_history {
    my ( $self ) = @_;
    my $address = $self + 0;
    $command_history->{$address} = [];
}

=head2 commands()

return overridden command names

=cut

sub commands {
    my ( $self ) = @_;
    my @result =  sort keys %{ $self->{my_commands} };
    return @result;
}

# commands registered in global structure
sub _registered_commands {
    my @result =  sort keys %{ $command_registry };
    return @result;
}

sub _unset_all_commands {
    my ( $self ) = @_;
    for my $command ( $self->commands() ) {
        delete $command_registry->{$command};
    }
    $self->{my_commands} = {};
    $self->reset_history();
}

sub DESTROY {
    my ( $self ) = @_;
    $self->_unset_all_commands() if ( defined $self );
}

1;
__END__