File Coverage

blib/lib/Devel/Stub.pm

Criterion	Covered	Total	%
statement	59	61	96.7
branch	6	10	60.0
condition			n/a
subroutine	12	12	100.0
pod	1	1	100.0
total	78	84	92.8

package Devel::Stub;
use strict;
use warnings;
use Module::Load;
use Sub::Name qw/subname/;
use version;
our $VERSION = qv('0.02');

sub stub {
    my %params = @_;
    my @tags;
    if ($params{TAG}){
      @tags = ref($params{TAG}) ? @{$params{TAG}} : ($params{TAG});
      delete $params{TAG};
      return unless $ENV{STUB_TAG};
      return unless grep { $_ eq $ENV{STUB_TAG}} @tags;
    }
    my ($name,$code) = %params;
    no strict 'refs';
    no warnings 'redefine';
    my ($pkg,$file,$line) = caller;
    my $original = \&{"${pkg}::${name}"};
    *{"${pkg}::__original_${name}"} = $original;
    *{"${pkg}::${name}"} = subname $name,$code;
}

sub import{
    my $class = shift;
    my %params = @_ ;

    if ( $params{on}  ){
        my ($pkg,$file) = caller;
        no strict 'refs';
        *{"${pkg}::stub"} = \&stub;
        *{"${pkg}::_original"} = sub {
          no strict 'refs' ;
          my (undef,undef,undef,$subr) = caller(1);
          my $name = ( split /::/,$subr )[-1];
          &{"${pkg}::__original_${name}"}(@_);
        };
        my $pkgpath = $pkg;
        $pkgpath =~ s/::/\//g;
        $pkgpath .= ".pm";
        $file =~ s/[\w\/]+(\/$pkgpath)$/$params{on}$1/;
        load $file;
    }
}


1;

__END__