File Coverage

inc/Test2/Plugin/INC_Jail.pm
Criterion Covered Total %
statement 31 31 100.0
branch 12 16 75.0
condition n/a
subroutine 6 6 100.0
pod n/a
total 49 53 92.4


line stmt bran cond sub pod time code
1             package Test2::Plugin::INC_Jail;
2              
3 7     7   11461 use 5.008001;
  7         27  
4              
5 7     7   34 use strict;
  7         13  
  7         156  
6 7     7   32 use warnings;
  7         15  
  7         164  
7              
8 7     7   35 use Carp;
  7         13  
  7         2637  
9              
10             our $VERSION = '0.007_01';
11              
12             sub import {
13 7     7   71 my ( undef, $test_class, @test_inc ) = @_;
14              
15 7         23 my $caller = caller;
16              
17 7 100       26 unless ( defined $test_class ) {
18 6 50       71 my $code = $caller->can( 'CLASS' )
19             or croak 'No test class specified and caller does not define CLASS';
20 6         21 $test_class = $code->();
21             }
22              
23             @test_inc
24 7 50       25 or push @test_inc, 't/lib';
25 7         17 foreach ( @test_inc ) {
26             -d
27 7 50       170 or croak "Test module directory $_ not found";
28             }
29              
30             unshift @INC, sub {
31              
32 160     160   920267 my $lvl = 0;
33              
34 160         578 while ( my $pkg = caller $lvl ) {
35              
36 261 100       491 if ( $test_class eq $pkg ) {
37 19         55 foreach my $dir ( @test_inc ) {
38 19         29 my $fh;
39 19 50       4058 open $fh, '<', "$dir/$_[1]"
    100          
40             and return $] ge '5.020' ? ( \'', $fh ) : $fh;
41             }
42 9         1538 croak "Can't locate $_[1] in \@INC";
43             }
44              
45             # The reason we have to iterate if the package is our
46             # original caller is that the module under test might be
47             # loading the requested module on behalf of said caller by
48             # doing a stringy eval in the caller's name space.
49 242 100       63590 $caller eq $pkg
50             or return;
51              
52             } continue {
53 109         224 $lvl++;
54             }
55 8         3212 return;
56 7         58 };
57              
58 7         213 return;
59             }
60              
61             1;
62              
63             __END__