view release on metacpan or  search on metacpan

inc/Test/MockObject.pm  view on Meta::CPAN

#line 1
package Test::MockObject;
BEGIN {
  $Test::MockObject::VERSION = '1.20110612';
}

use strict;
use warnings;

use Scalar::Util qw( blessed refaddr reftype weaken );

sub import
{
    my $self = shift;
    return unless grep /^-debug/, @_;
    eval "use UNIVERSAL::isa 'verbose'";
    eval "use UNIVERSAL::can '-always_warn'";
}

use Test::Builder;

my $Test = Test::Builder->new();
my (%calls, %subs);

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

sub mock
{
    my ($self, $name, $sub) = @_;
    $sub ||= sub {};

    # leading dash means unlog, otherwise do log
    _set_log( $self, $name, ( $name =~ s/^-// ? 0 : 1 ) );
    _subs( $self )->{$name} = $sub;

    $self;
}

sub set_isa
{
    my ($self, @supers) = @_;
    my $supers          = _isas( $self );
    $supers->{$_}       = 1 for @supers;
}

sub set_always
{
    my ($self, $name, $value) = @_;
    $self->mock( $name, sub { $value } );
}

sub set_true
{
    my $self = shift;

    for my $name ( @_ )
    {
        $self->mock( $name, sub { 1 } );
    }

    return $self;
}

sub set_false
{

inc/Test/MockObject.pm  view on Meta::CPAN

sub call_args_pos
{
    my ($self, $subpos, $argpos) = @_;
    my $args = $self->_call( $subpos, 1 ) or return;
    $argpos-- if $argpos > 0;
    return $args->[$argpos];
}

sub next_call
{
    my ($self, $num)  = @_;
    $num            ||= 1;

    my $calls = _calls( $self );
    return unless @$calls >= $num;

    my ($call) = (splice(@$calls, 0, $num))[-1];
    return wantarray() ? @$call : $call->[0];
}

sub AUTOLOAD
{
    our $AUTOLOAD;

    my $self = shift;
    my $sub;
    {
        local $1;
        ($sub) = $AUTOLOAD =~ /::(\w+)\z/;
    }
    return if $sub eq 'DESTROY';

    $self->dispatch_mocked_method( $sub, @_ );
}

sub dispatch_mocked_method
{
    my $self = $_[0];
    my $sub  = splice( @_, 1, 1 );

    my $subs = _subs( $self );
    if (exists $subs->{$sub})
    {
        $self->log_call( $sub, @_ );
        goto &{ $subs->{$sub} };
    }
    else
    {
        require Carp;
        Carp::carp("Un-mocked method '$sub()' called");
    }

    return;
}

sub log_call
{
    my ($self, $sub, @call_args) = @_;
    return unless _logs( $self, $sub );

    # prevent circular references with weaken
    for my $arg ( @call_args )
    {
        next unless ref $arg;
        weaken( $arg ) if refaddr( $arg ) eq refaddr( $self );
    }

    push @{ _calls( $self ) }, [ $sub, \@call_args ];
}

sub called_ok
{
    my ($self, $sub, $name) = @_;
    $name ||= "object called '$sub'";
    $Test->ok( $self->called($sub), $name );
}

sub called_pos_ok
{
    my ($self, $pos, $sub, $name) = @_;
    $name ||= "object called '$sub' at position $pos";
    my $called = $self->call_pos($pos, $sub);
    unless ($Test->ok( (defined $called and $called eq $sub), $name ))
    {
        $called = 'undef' unless defined $called;
        $Test->diag("Got:\n\t'$called'\nExpected:\n\t'$sub'\n");
    }
}

sub called_args_string_is
{
    my ($self, $pos, $sep, $expected, $name) = @_;
    $name ||= "object sent expected args to sub at position $pos";
    $Test->is_eq( $self->call_args_string( $pos, $sep ), $expected, $name );
}

sub called_args_pos_is
{
    my ($self, $pos, $argpos, $arg, $name) = @_;
    $name ||= "object sent expected arg '$arg' to sub at position $pos";
    $Test->is_eq( $self->call_args_pos( $pos, $argpos ), $arg, $name );
}

sub fake_module
{
    my ($class, $modname, %subs) = @_;

    if ($class->check_class_loaded( $modname ) and ! keys %subs)
    {
        require Carp;
        Carp::croak( "No mocked subs for loaded module '$modname'" );
    }

    $modname =~ s!::!/!g;
    $INC{ $modname . '.pm' } = 1;

    no warnings 'redefine';
    {
        no strict 'refs';
        ${ $modname . '::' }{VERSION} ||= -1;
    }

    for my $sub (keys %subs)
    {
        my $type = reftype( $subs{ $sub } ) || '';