File Coverage

blib/lib/Sub/Frequency.pm

Criterion	Covered	Total	%
statement	32	33	96.9
branch	9	12	75.0
condition	4	4	100.0
subroutine	10	10	100.0
pod	1	1	100.0
total	56	60	93.3

package Sub::Frequency;

use strict;
use warnings;

use Scalar::Util 'looks_like_number';
use Carp 'croak';

use parent 'Exporter';

our @EXPORT = qw(
  always normally usually often sometimes maybe
  rarely seldom never with_probability
);

our @EXPORT_OK = @EXPORT;

our $VERSION = '0.05';

my %probabilities = (
    'Sub::Frequency::Always'    => 1.00,
    'Sub::Frequency::Normally'  => 0.75,
    'Sub::Frequency::Sometimes' => 0.50,
    'Sub::Frequency::Rarely'    => 0.25,
    'Sub::Frequency::Never'     => 0.00,
);

foreach my $name (keys %probabilities) {
    (my $subname = lc($name)) =~ s/.*:://g;
    no strict 'refs';
    *$subname = sub (&;@) {
         my ( $code, @rest ) = @_;
        if (wantarray) {
            return ( bless( $code, $name ), @rest );
        }
        else {
            _exec( $code, $name, @rest );
        }
    }
}

sub with_probability ($;&) {
    my ( $probability, $code ) = @_;

    $probability = _coerce($probability)
      unless looks_like_number($probability);

    $code->() if rand() <= $probability;
}

*often   = \&normally;
*usually = \&normally;
*maybe   = \&sometimes;
*seldom  = \&rarely;

sub _exec {
    my ( $code, $name, @rest ) = @_;

    $code->() and return if rand() < $probabilities{$name};

    foreach $code (@rest) {
        $code->() and last if rand() < $probabilities{ ref($code) };
    }
}

sub _coerce {
    my $thing = shift;

    # matches N%, .N% and N.N%
    if ( $thing =~ m/^\s*(\d+|\d*\.\d+)\s*%\s*$/ ) {
        return $1 / 100;
    }
    else {
        croak "'$thing' does not look like a number or a percentage.";
    }
}

42;
__END__