File Coverage

blib/lib/Test/MockCommand.pm

Criterion	Covered	Total	%
statement	175	178	98.3
branch	75	100	75.0
condition	18	28	64.2
subroutine	33	33	100.0
pod	12	12	100.0
total	313	351	89.1

package Test::MockCommand;
use warnings;
use strict;

use Carp qw(carp croak);
use Data::Dumper;
use Symbol;

# Not all systems implement the WIFEXITED/WEXITSTATUS macros
use POSIX qw(WIFEXITED WEXITSTATUS);
eval { WIFEXITED(0); };
if ($@ =~ /not (?:defined|a valid|implemented)/) {
    no warnings 'redefine';
    *WIFEXITED   = sub { not $_[0] & 0xff };
    *WEXITSTATUS = sub { $_[0] >> 8  };
}

use Test::MockCommand::Recorder;
use Test::MockCommand::Result;
use Test::MockCommand::ScalarReadline qw(scalar_readline);

our $VERSION = '0.05';
our $CLASS = __PACKAGE__;
our $OPEN_HANDLER = undef; # this gets set to _default_open_handler
our $RECORDING = 0;        # are we recording commands or playing them back?
our $RECORDING_TO = undef; # where to save results when the program ends
our %COMMANDS;             # results db: $COMMANDS{$cmd} = [ $result, ... ]
our @RECORDERS = ( Test::MockCommand::Recorder->new() );

#carp "WARNING: need perl v5.9.5 or better to mock qx// and backticks"
#    if $] < 5.009005;

$CLASS->open_handler(undef); # set up _default_open_handler
$CLASS->_hook_core_functions();

sub import {
    if (@_ >= 3 && $_[1] eq 'record') {
	$CLASS->auto_save($_[2]);
	$CLASS->recording(1);
    }
    elsif (@_ >= 3 && $_[1] eq 'playback') {
        $CLASS->load($_[2]);
    }
}

END { $CLASS->_do_autosave(); }

sub _do_autosave {
    my $class = shift;
    $class->save($RECORDING_TO) if defined $RECORDING_TO;

}

# hook into core functions that can execute external commands
sub _hook_core_functions {
    my $class = shift;

    *CORE::GLOBAL::system = sub {
	my $cmd = join(' ', @_);
	return $class->_handle('system', $cmd, \@_, [caller()]);
    };

    *CORE::GLOBAL::exec = sub {
	my $cmd = join(' ', @_);
	return $class->_handle('exec', $cmd, \@_, [caller()]);
    };

    *CORE::GLOBAL::readpipe = sub {
	my $cmd = $_[-1];
	return $class->_handle('readpipe', $cmd, \@_, [caller()]);
    };

    *CORE::GLOBAL::open = sub (*;$@) {
	croak "Not enough arguments for open()" unless @_ > 0;
	# handle open()s that invoke a command
	if (@_ < 3) {
	    # 1/2-arg open()
	    my $file = $_[-1];
	    croak "Can't open bidirectional pipe" if $file =~/^\s*\|(.+)\|\s*$/;
	    return $class->_handle('open', $1, \@_, [caller()])
	        if $file =~ /^\s*\|\s*(.+?)\s*$/;
	    return $class->_handle('open', $1, \@_, [caller()])
	        if $file =~ /^\s*(.+?)\s*\|\s*$/;
	}
	else {
	    # 3-arg open()
	    return $class->_handle('open', join(' ', splice(@_, 2)), \@_,
				  [caller()])
	        if $_[1] =~ /^\s*-\|/;
	    return $class->_handle('open', join(' ', splice(@_, 2)), \@_,
				  [caller()])
	        if $_[1] =~ /^\s*\|-/;
	}

	# pass through the rest
	return $OPEN_HANDLER->(\@_, caller());
    };
}

sub _handle {
    my ($class, $func, $cmd, $args, $caller) = @_;

    my %args = (
        command     => $cmd,
	function    => $func,
	arguments   => $args,
	caller      => $caller,
    );

    my $result = undef;
    my $return = undef;

    if ($RECORDING) {
	# recording mode: find a capable recorder
	for my $recorder (@RECORDERS) {
	    $result = $recorder->handle(%args);
	    last if defined $result;
	}

	if ($result) {
	    # save result in database
	    $COMMANDS{"$func:$cmd"} ||= [];
	    push @{$COMMANDS{"$func:$cmd"}}, $result;
	    $return = $result->return_value();
	}
    }
    else {
	# not in recording mode; look up results database instead.
	my @possible = $class->find(%args);
	if (@possible) {
	    $result = $possible[0];
	    $return = $result->handle(%args, all_results => \@possible);
	}
    }

    # warn and pass through if no matching commands
    if (! defined $result) {
	carp "can't mock $func() command \"$cmd\", passing through";
	return $OPEN_HANDLER->($args, $caller->[0]) if $func eq 'open';
	return CORE::readpipe(@{$args})             if $func eq 'readpipe';
	return CORE::system(@{$args})               if $func eq 'system';
	return CORE::exec(@{$args})                 if $func eq 'exec';
    }

    # if exec() was called, save the db and exit
    if ($func eq 'exec') {
	$class->_do_autosave();
	my $code = $result->exit_code();
	exit(WIFEXITED($code) ? WEXITSTATUS($code) : $code);
    }

    # readpipe() emulation should always return a scalar, so
    # emulation of $/ behaviour is used in list context
    return scalar_readline($return) if $func eq 'readpipe' && wantarray();

    # return with the function's result
    return $return;
}

# this is the default $OPEN_HANDLER, use for any non-command-executing
# open(), also for command-executing open()s when there's no matching
# recorder or result
sub _default_open_handler {
    my ($args, $pkg) = @_;

    # we might need to use a bareword symbol reference in the open() call
    no strict 'refs';

    # if defined, open()'s file handle is a bareword symbol reference which
    # should be qualified as being in the calling package's namespace.
    my $ref = defined($args->[0]) ? Symbol::qualify($args->[0], $pkg) : undef;

    # open() is finicky about its arguments, it doesn't like just @{$args}.
    # If the file handle is undefined, we refer directly to it so that open()
    # can use the pass-by-reference to assign a new value into it.
    return CORE::open($ref || $args->[0]) if @{$args} == 1;
    return CORE::open($ref || $args->[0], $args->[1]) if @{$args} == 2;
    return CORE::open($ref || $args->[0], $args->[1], splice(@{$args}, 2));
}

sub clear {
    %COMMANDS = ();
}

sub load {
    my $class = shift;
    my $file = shift;
    croak "no file specified" unless defined $file;

    $class->clear();
    $class->merge($file);
}

sub merge {
    my $class = shift;
    my $file = shift;
    croak "no file specified" unless defined $file;
    croak "$file is a directory" if -d $file;

    # read and evaluate file, which should set up $VAR1
    my $VAR1 = undef;
    local $/; # enable slurp mode
    open(my $fh, '<', $file) or croak "can't open $file: $!";
    eval <$fh>;
    close $fh;
    croak "failure loading $file: $@" if $@;
    croak "failure loading $file: \$VAR1 not defined" unless defined $VAR1;

    # merge $VAR1 into %COMMANDS
    for my $cmd (keys %{$VAR1}) {
	$COMMANDS{$cmd} ||= [];
	push @{$COMMANDS{$cmd}}, @{$VAR1->{$cmd}};
    }
}

sub save {
    my $class = shift;
    my $file = shift;

    # use auto-save file if no file specified
    $file = $RECORDING_TO unless defined $file;
    croak "no file specified and auto-save not enabled" unless defined $file;

    open FH, ">$file" or croak "can't save to $file: $!";
    print FH Dumper(\%COMMANDS) or croak "can't write results to $file: $!";
    close FH or croak "can't close $file: $!";
}

sub add_recorder {
    my $class = shift;
    my $recorder = shift || croak 'no recorder provided';
    croak "recorder has no handle() method"
        unless UNIVERSAL::can($recorder, 'handle');
    unshift @RECORDERS, $recorder;
}

sub remove_recorder {
    my $class = shift;
    my $recorder = shift || croak 'no recorder provided';
    @RECORDERS = grep { $_ != $recorder } @RECORDERS;
}

sub recorders {
    return @RECORDERS;
}

sub find {
    my $class = shift;
    croak "odd number of parameters" if @_ % 2;
    my %args = @_;

    my @keys;
    if (exists $args{command}) {
	if (ref $args{command} eq 'Regexp') {
	    my $re = exists $args{function}
	        ? qr/^\Q$args{function}\E:(.+)/
	        : qr/^(?:exec|open|readpipe|system):(.+)/;
	    @keys = grep { $_ =~ $re && $1 =~ $args{command} } keys %COMMANDS;
	}
	else {
	    @keys = grep {exists $COMMANDS{$_}} map {"$_:$args{command}"}
	        (exists $args{function}
		 ? ($args{function})
		 : qw(exec open readpipe system));
	}
    }
    else {
	@keys = keys %COMMANDS;
	@keys = grep {/^\Q$args{function}\E:/} @keys if exists $args{function};
    }

    # we can't just return sort{} grep{}... as the expression gives
    # undef when the caller wants a scalar context... why?
    my %score;
    my @results = sort { $score{$b} <=> $score{$a} }
                  grep { $score{$_} = $_->matches(%args) }
		  map  { @{$COMMANDS{$_}} }
		  @keys;
    return @results;
}

sub all_commands {
    return map { @{$_} } values %COMMANDS;
}

sub recording {
    my $class = shift;
    if (@_ >= 1) {
	croak 'value to recording() not valid' unless defined $_[0];
	$RECORDING = shift;
    }
    return $RECORDING;
}

sub auto_save {
    my $class = shift;
    $RECORDING_TO = shift if @_ >= 1;
    return $RECORDING_TO;
}

sub open_handler {
    my $class = shift;
    croak 'wrong number of parameters' unless @_ == 1;
    if (defined $_[0]) {
	croak 'parameter must be coderef' unless ref $_[0] eq 'CODE';
	$OPEN_HANDLER = $_[0];
    }
    else {
	$OPEN_HANDLER = \&_default_open_handler;
    }
}

1;

__END__