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

package Test::MockPackages;
use strict;
use warnings;
use utf8;
use 5.010;

our $VERSION = '1.01';

use Carp qw(croak);
use English qw(-no_match_vars);
use Exporter qw(import);
use Test::MockPackages::Mock();
use Test::MockPackages::Package();
use Test::MockPackages::Returns qw(returns_code);

our @EXPORT_OK = qw(mock returns_code);

sub new {
    my ( $pkg ) = @ARG;

    return bless { '_packages' => {}, }, $pkg;
}

sub pkg {
    my ( $self, $pkg_name ) = @ARG;

    if ( !$pkg_name || ref( $pkg_name ) ) {
        croak( '$pkg_name is required and must be a SCALAR' );
    }

    if ( my $pkg = $self->{_packages}{$pkg_name} ) {
        return $pkg;
    }

    return $self->{_packages}{$pkg_name} = Test::MockPackages::Package->new( $pkg_name );
}

sub mock {
    my ( $config ) = @ARG;

    _must_validate( $config );

    # this while loop is similar to the one found in _must_validate, but I'm explicitly keeping them separate
    # so that we don't end up with partially built and mocked subroutines and methods.
    my $m = Test::MockPackages->new();
    while ( my ( $pkg, $subs_href ) = each %$config ) {
        my $mp = $m->pkg( $pkg );

        while ( my ( $sub, $config_aref ) = each %$subs_href ) {
            my $ms = $mp->mock( $sub );

            for ( my $i = 0; $i < @$config_aref; $i += 2 ) {
                my ( $mock_method, $args_aref ) = @$config_aref[ $i, $i + 1 ];

                my $method = $ms->can( $mock_method );
                $ms->$method( @$args_aref );
            }
        }
    }

    return $m;
}

sub _must_validate {
    my ( $config ) = @ARG;

    if ( ref( $config ) ne 'HASH' ) {
        croak( 'config must be a HASH' );
    }

    while ( my ( $pkg, $subs_href ) = each %$config ) {
        if ( ref( $subs_href ) ne 'HASH' ) {
            croak( "value for $pkg must be a HASH" );
        }

        while ( my ( $sub, $config_aref ) = each %$subs_href ) {
            if ( ref( $config_aref ) ne 'ARRAY' ) {
                croak( "value for ${pkg}::$sub must be an ARRAY" );
            }

            if ( @$config_aref % 2 > 0 ) {
                croak( "value for ${pkg}::$sub must be an even-sized ARRAY" );
            }

            for ( my $i = 0; $i < @$config_aref; $i += 2 ) {
                my ( $mock_method, $args_aref ) = @$config_aref[ $i, $i + 1 ];

                if ( ref( $args_aref ) ne 'ARRAY' ) {
                    croak( "arguments must be an ARRAY for mock method $mock_method in ${pkg}::$sub" );
                }

                if (!do {
                        local $EVAL_ERROR = undef;
                        eval { Test::MockPackages::Mock->can( $mock_method ) };
                    }
                    )
                {
                    croak( "$mock_method is not a capability of Test::MockPackages::Mock in ${pkg}::$sub" );
                }
            }
        }
    }

    return 1;
}

sub DESTROY {
    my ( $self ) = @ARG;

    # this is to ensure that the objects are destroyed in a consistent order.
    for my $pkg ( sort keys %{ $self->{_packages} } ) {
        delete $self->{_packages}{$pkg};
    }

    return;
}

1;

__END__