File Coverage

blib/lib/Test/MockPackages.pm
Criterion Covered Total %
statement 75 75 100.0
branch 16 16 100.0
condition 3 3 100.0
subroutine 15 15 100.0
pod 3 3 100.0
total 112 112 100.0


line stmt bran cond sub pod time code
1             package Test::MockPackages;
2 4     4   92305 use strict;
  4         10  
  4         135  
3 4     4   18 use warnings;
  4         6  
  4         177  
4 4     4   2880 use utf8;
  4         52  
  4         29  
5 4     4   215 use 5.010;
  4         13  
6              
7             our $VERSION = '1.00';
8              
9 4     4   23 use Carp qw(croak);
  4         880  
  4         523  
10 4     4   2238 use English qw(-no_match_vars);
  4         10329  
  4         26  
11 4     4   1551 use Exporter qw(import);
  4         6  
  4         121  
12 4     4   2143 use Test::MockPackages::Mock();
  4         13  
  4         129  
13 4     4   2071 use Test::MockPackages::Package();
  4         25  
  4         82  
14 4     4   1521 use Test::MockPackages::Returns qw(returns_code);
  4         7  
  4         2854  
15              
16             our @EXPORT_OK = qw(mock returns_code);
17              
18             sub new {
19 4     4 1 1449 my ( $pkg ) = @ARG;
20              
21 4         28 return bless { '_packages' => {}, }, $pkg;
22             }
23              
24             sub pkg {
25 10     10 1 78 my ( $self, $pkg_name ) = @ARG;
26              
27 10 100 100     52 if ( !$pkg_name || ref( $pkg_name ) ) {
28 2         38 croak( '$pkg_name is required and must be a SCALAR' );
29             }
30              
31 8 100       30 if ( my $pkg = $self->{_packages}{$pkg_name} ) {
32 2         10 return $pkg;
33             }
34              
35 6         30 return $self->{_packages}{$pkg_name} = Test::MockPackages::Package->new( $pkg_name );
36             }
37              
38             sub mock {
39 7     7 1 102244 my ( $config ) = @ARG;
40              
41 7         15 _must_validate( $config );
42              
43             # this while loop is similar to the one found in _must_validate, but I'm explicitly keeping them separate
44             # so that we don't end up with partially built and mocked subroutines and methods.
45 1         7 my $m = Test::MockPackages->new();
46 1         5 while ( my ( $pkg, $subs_href ) = each %$config ) {
47 2         6 my $mp = $m->pkg( $pkg );
48              
49 2         8 while ( my ( $sub, $config_aref ) = each %$subs_href ) {
50 4         16 my $ms = $mp->mock( $sub );
51              
52 4         14 for ( my $i = 0; $i < @$config_aref; $i += 2 ) {
53 11         15 my ( $mock_method, $args_aref ) = @$config_aref[ $i, $i + 1 ];
54              
55 11         23 my $method = $ms->can( $mock_method );
56 11         28 $ms->$method( @$args_aref );
57             }
58             }
59             }
60              
61 1         26 return $m;
62             }
63              
64             sub _must_validate {
65 7     7   9 my ( $config ) = @ARG;
66              
67 7 100       24 if ( ref( $config ) ne 'HASH' ) {
68 1         30 croak( 'config must be a HASH' );
69             }
70              
71 6         24 while ( my ( $pkg, $subs_href ) = each %$config ) {
72 7 100       18 if ( ref( $subs_href ) ne 'HASH' ) {
73 1         14 croak( "value for $pkg must be a HASH" );
74             }
75              
76 6         16 while ( my ( $sub, $config_aref ) = each %$subs_href ) {
77 8 100       17 if ( ref( $config_aref ) ne 'ARRAY' ) {
78 1         13 croak( "value for ${pkg}::$sub must be an ARRAY" );
79             }
80              
81 7 100       16 if ( @$config_aref % 2 > 0 ) {
82 1         17 croak( "value for ${pkg}::$sub must be an even-sized ARRAY" );
83             }
84              
85 6         15 for ( my $i = 0; $i < @$config_aref; $i += 2 ) {
86 13         21 my ( $mock_method, $args_aref ) = @$config_aref[ $i, $i + 1 ];
87              
88 13 100       25 if ( ref( $args_aref ) ne 'ARRAY' ) {
89 1         13 croak( "arguments must be an ARRAY for mock method $mock_method in ${pkg}::$sub" );
90             }
91              
92 12 100       10 if (!do {
93 12         14 local $EVAL_ERROR = undef;
94 12         15 eval { Test::MockPackages::Mock->can( $mock_method ) };
  12         98  
95             }
96             )
97             {
98 1         14 croak( "$mock_method is not a capability of Test::MockPackages::Mock in ${pkg}::$sub" );
99             }
100             }
101             }
102             }
103              
104 1         2 return 1;
105             }
106              
107             sub DESTROY {
108 4     4   744 my ( $self ) = @ARG;
109              
110             # this is to ensure that the objects are destroyed in a consistent order.
111 4         14 for my $pkg ( sort keys %{ $self->{_packages} } ) {
  4         57  
112 6         53 delete $self->{_packages}{$pkg};
113             }
114              
115 4         123 return;
116             }
117              
118             1;
119              
120             __END__