File Coverage

blib/lib/Test/Mock/Test.pm

Criterion	Covered	Total	%
statement	50	52	96.1
branch	3	6	50.0
condition			n/a
subroutine	18	19	94.7
pod	0	8	0.0
total	71	85	83.5

package Test::Mock::Test;

use 5.006001;

$VERSION = 0.01;

use strict;
use warnings;

use Carp;
use Scalar::Util 1.11 'set_prototype';
use Symbol qw/ qualify_to_ref qualify /;

require Test::More;

our $no_test_builder = 0;
our $builder = Test::More->builder;

my %mocks = (
             "Test::More" => {
                              proto_S_S   => [qw( ok )],
                              proto_SS_S  => [qw( is isnt like unlike isa_ok )],
                              proto_SSS_S => [qw( cmp_ok )],

                              noproto_2   => [qw( is_deeply )],

                              can_ok      => [qw( can_ok )],
                              fail        => [qw( fail )],
                              use_ok      => [qw( use_ok )],
                              require_ok  => [qw( require_ok )],
                             },
             "Test::Deep" => {
                              noproto_2   => [qw( cmp_bag cmp_deeply )],
                             },
            );

sub import {
        foreach (@_) {
                $no_test_builder = 1 if /no_test_builder/;
        }

        ## no critic (ProhibitStringyEval)
        ## needed for sub prototypes
        if ($no_test_builder)
        {
                eval '
                      sub proto_S_S   ($;$)   { 1 };
                      sub proto_SS_S  ($$;$)  { 1 };
                      sub proto_SSS_S ($$$;$) { 1 };
                      sub fail        (;$)    { 1 };
                      sub can_ok      ($@)    { 1 };
                      sub use_ok      ($;@)   { 1 };
                      sub require_ok  ($)     { 1 };
                      sub noproto_2   ($$;$)  { 1 };
                     ';
        }
        else
        {
                eval '
                      sub proto_S_S   ($;$)   { $builder->ok( 1, $_[1] ) };
                      sub proto_SS_S  ($$;$)  { $builder->ok( 1, $_[2] ) };
                      sub proto_SSS_S ($$$;$) { $builder->ok( 1, $_[3] ) };
                      sub fail        (;$)    { $builder->ok( 1, @_ ) };
                      sub can_ok      ($@)    { $builder->ok( 1, "class->can(...)") };
                      sub use_ok      ($;@)   { $builder->ok( 1, "use ".$_[0].";" ) };
                      sub require_ok  ($)     { $builder->ok( 1, "require ".$_[0].";" ) };
                      sub noproto_2   ($$;$)  { $builder->ok( 1, $_[2] ) };
                     ';
        }
}


CHECK {
        no strict "refs";

        for my $module (keys %mocks) {
                for my $mocksub (keys %{$mocks{$module}}) {
                        for my $sub (@{$mocks{$module}{$mocksub}}) {
                                my $glob          = qualify_to_ref($sub => $module);
                                my $mocksub_proto = set_prototype(sub { &{$mocksub} }, prototype \&$glob);
                                {
                                        no warnings 'redefine';
                                        *{$module."::".$sub} = $mocksub_proto;
                                        *{"main" ."::".$sub} = $mocksub_proto if *{"main" ."::".$sub};
                                }
                        }
                }
        }
}

1;

__END__