File Coverage

blib/lib/Test/Stub.pm

Criterion	Covered	Total	%
statement	46	48	95.8
branch	4	4	100.0
condition	5	5	100.0
subroutine	12	14	85.7
pod	2	2	100.0
total	69	73	94.5

package Test::Stub;
use strict;
use warnings;
use 5.008001;
our $VERSION = '0.04';
use parent qw/Exporter/;

our @EXPORT = qw/stub make_stub/;

sub stub {
    bless \$_[0], 'Test::Stub::Driver';
}

my $id = 0;
sub make_stub {
    my $object = shift;
    my $method = shift;
    my $stub = shift || sub {};

    my $func = ref($stub) eq 'CODE' ? $stub : sub { $stub };

    my $pkg = "Test::Stub::Anon" . $id++;

    # stubbing.
    {
        no strict 'refs';
        unshift @{"$pkg\::ISA"}, ref $$object;
        *{"$pkg\::$method"} = $func;
    }

    # rebless
    bless $$object, $pkg;

    return;
}

package Test::Stub::Driver;
use strict;
use warnings;

use Carp qw(croak);

our $AUTOLOAD;
sub DESTROY { }
sub AUTOLOAD {
    $AUTOLOAD =~ s/.*:://;
    my $method = $AUTOLOAD;

    my $self = shift;

    if (UNIVERSAL::can($$self, $method) || UNIVERSAL::can($$self, 'AUTOLOAD')) {
        Test::Stub::make_stub($self, $method, @_);
        return;
    } else {
        # Throw the same kind of error that perl would throw if you attempt to call
        # some unknown method on an object
        my $package = ref($$self);
        croak(qq{Can't locate object method "$method" via package "$package"});
    }
}

1;
__END__