File Coverage

blib/lib/Test/MockRandom.pm

Criterion	Covered	Total	%
statement	88	88	100.0
branch	32	32	100.0
condition	11	13	84.6
subroutine	18	18	100.0
pod	7	7	100.0
total	156	158	98.7

use strict;
use warnings;

package Test::MockRandom;
# ABSTRACT: Replaces random number generation with non-random number generation
our $VERSION = '1.01'; # VERSION

use Carp qw/croak/;

#--------------------------------------------------------------------------#
# Class data
#--------------------------------------------------------------------------#

my @data = (0);

#--------------------------------------------------------------------------#
# new()
#--------------------------------------------------------------------------#

sub new {
    my ( $class, @data ) = @_;
    my $self = bless( [], ref($class) || $class );
    $self->srand(@data);
    return $self;
}

#--------------------------------------------------------------------------#
# srand()
#--------------------------------------------------------------------------#

sub srand { ## no critic
    if ( ref( $_[0] ) eq __PACKAGE__ ) {
        my $self = shift;
        @$self = $self->_test_srand(@_);
        return;
    }
    else {
        @data = Test::MockRandom->_test_srand(@_);
        return;
    }
}

sub _test_srand {
    my ( $self, @data ) = @_;
    my $error =
      "Seeds for " . __PACKAGE__ . " must be between 0 (inclusive) and 1 (exclusive)";
    croak $error if grep { $_ < 0 or $_ >= 1 } @data;
    return @data ? @data : (0);
}

#--------------------------------------------------------------------------#
# rand()
#--------------------------------------------------------------------------#

sub rand(;$) { ## no critic
    my ( $mult, $val );
    if ( ref( $_[0] ) eq __PACKAGE__ ) { # we're a MockRandom object
        $mult = $_[1];
        $val = shift @{ $_[0] } || 0;
    }
    else {
        # we might be called as a method of some other class
        # so we need to ignore that and get the right multiplier
        $mult = $_[ ref( $_[0] ) ? 1 : 0 ];
        $val = shift @data || 0;
    }
    # default to 1 for undef, 0, or strings that aren't numbers
    eval { no warnings; local $^W = 0; my $bogus = 1 / $mult };
    $mult = 1 if $@;
    return $val * $mult;
}

#--------------------------------------------------------------------------#
# oneish()
#--------------------------------------------------------------------------#

sub oneish {
    return ( 2**32 - 1 ) / ( 2**32 );
}

#--------------------------------------------------------------------------#
# import()
#--------------------------------------------------------------------------#

sub import {
    my ( $class, @import_list ) = @_;
    my $caller = caller(0);

    # Nothing exported by default or if empty string requested
    return unless @import_list;
    return if ( @import_list == 1 && $import_list[0] eq '' );

    for my $tgt (@import_list) {
        # custom handling if it's a hashref
        if ( ref($tgt) eq "HASH" ) {
            for my $sym ( keys %$tgt ) {
                croak "Unrecognized symbol '$sym'"
                  unless grep { $sym eq $_ } qw (rand srand oneish);
                my @custom = ref( $tgt->{$sym} ) eq 'ARRAY' ? @{ $tgt->{$sym} } : $tgt->{$sym};
                _custom_export( $sym, $_ ) for (@custom);
            }
        }
        # otherwise, export rand to target and srand/oneish to caller
        else {
            my $pkg = ( $tgt =~ /^__PACKAGE__$/ ) ? $caller : $tgt; # DWIM
            _export_symbol( "rand", $pkg );
            _export_symbol( $_, $caller ) for qw( srand oneish );
        }
    }
    return;
}

#--------------------------------------------------------------------------#
# export_oneish_to()
#--------------------------------------------------------------------------#

sub export_oneish_to {
    my ( $class, @args ) = @_;
    _export_fcn_to( $class, "oneish", @args );
    return;
}

#--------------------------------------------------------------------------#
# export_rand_to()
#--------------------------------------------------------------------------#

sub export_rand_to {
    my ( $class, @args ) = @_;
    _export_fcn_to( $class, "rand", @args );
    return;
}

#--------------------------------------------------------------------------#
# export_srand_to()
#--------------------------------------------------------------------------#

sub export_srand_to {
    my ( $class, @args ) = @_;
    _export_fcn_to( $class, "srand", @args );
    return;
}

#--------------------------------------------------------------------------#
# _custom_export
#--------------------------------------------------------------------------#

sub _custom_export {
    my ( $sym, $custom ) = @_;
    if ( ref($custom) eq 'HASH' ) {
        _export_symbol( $sym, %$custom ); # flatten { pkg => 'alias' }
    }
    else {
        _export_symbol( $sym, $custom );
    }
    return;
}

#--------------------------------------------------------------------------#
# _export_fcn_to
#--------------------------------------------------------------------------#

sub _export_fcn_to {
    my ( $self, $fcn, $pkg, $alias ) = @_;
    croak "Must call to export_${fcn}_to() as a class method"
      unless ( $self eq __PACKAGE__ );
    croak("export_${fcn}_to() requires a package name") unless $pkg;
    _export_symbol( $fcn, $pkg, $alias );
    return;
}

#--------------------------------------------------------------------------#
# _export_symbol()
#--------------------------------------------------------------------------#

sub _export_symbol {
    my ( $sym, $pkg, $alias ) = @_;
    $alias ||= $sym;
    {
        no strict 'refs'; ## no critic
        no warnings 'redefine';
        local $^W = 0;    # no redefine warnings
        *{"${pkg}::${alias}"} = \&{"Test::MockRandom::${sym}"};
    }
    return;
}

1;

__END__