File Coverage

blib/lib/Math/Random/MT/Auto.pm

Criterion	Covered	Total	%
statement	211	281	75.0
branch	58	96	60.4
condition	11	23	47.8
subroutine	33	33	100.0
pod	6	8	75.0
total	319	441	72.3

package Math::Random::MT::Auto; {

require 5.006;

use strict;
use warnings;

our $VERSION = '6.23';
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;

require Carp;
use Scalar::Util 1.18;

require XSLoader;
XSLoader::load('Math::Random::MT::Auto', $XS_VERSION);

use Object::InsideOut 2.06 ':hash_only';
use Object::InsideOut::Util 'shared_copy';

# Exceptions thrown by this package
use Exception::Class (
    'MRMA::Args' => {
        'isa' => 'OIO::Args',
        'description' =>
            'Math::Random::MT::Auto exception that indicates an argument error',
    },
);


### Inside-out Object Attributes ###

# Object data is stored in these attribute hashes, and is keyed to the object
# by a unique ID that is stored in the object's scalar reference.  For this
# class, that ID is the address of the PRNG's internal memory.
#
# These hashes are declared using the 'Field' attribute.

my %sources_for :Field;   # Sources from which to obtain random seed data
my %seed_for    :Field;   # Last seed sent to the PRNG


# Seed source subroutine dispatch table
my %DISPATCH = (
    'device'     => \&_acq_device,
    'random_org' => \&_acq_www,
    'hotbits'    => \&_acq_www,
    'rn_info'    => \&_acq_www,
);


### Module Initialization ###

# Handle exportation of subroutine names, user-specified and default
# seeding sources.  Also, auto-seeding of the standalone PRNG.
sub import
{
    my $class = shift;   # Not used

    # Exportable subroutines
    my %EXPORT_OK;
    @EXPORT_OK{qw(rand irand shuffle gaussian
                  exponential erlang poisson binomial
                  srand get_seed set_seed get_state set_state)} = undef;

    my $auto_seed = 1;   # Flag to auto-seed the standalone PRNG

    # Handle entries in the import list
    my $caller = caller();
    my @sources;
    while (my $sym = shift) {
        if (exists($EXPORT_OK{lc($sym)})) {
            # Export subroutine names
            no strict 'refs';
            *{$caller.'::'.$sym} = \&{lc($sym)};

        } elsif ($sym =~ /^:(no|!)?auto$/i) {
            # To auto-seed (:auto is default) or not (:!auto or :noauto)
            $auto_seed = not defined($1);

        } else {
            # User-specified seed acquisition sources
            # or user-defined seed acquisition subroutines
            push(@sources, $sym);
            # Add max. source count, if specified
            if (@_ && Scalar::Util::looks_like_number($_[0])) {
                push(@sources, shift);
            }
        }
    }

    # Setup default sources, if needed
    if (! @sources) {
        if (exists($DISPATCH{'win32'})) {
            push(@sources, 'win32');
        } elsif (-e '/dev/urandom') {
            push(@sources, '/dev/urandom');
        } elsif (-e '/dev/random') {
            push(@sources, '/dev/random');
        }
        push(@sources, 'random_org');
    }

    # Create standalone PRNG
    $MRMA::PRNG = Math::Random::MT::Auto->new(
                'SOURCE' => \@sources,
                ($auto_seed) ? () : ( 'SEED' => [ $$, time(), Scalar::Util::refaddr(\$VERSION) ] )
            );
}


### Dual-Interface (Functional and OO) Subroutines ###
#
# The subroutines below work both as regular 'functions' for the functional
# interface to the standalone PRNG, as well as methods for the OO interface
# to PRNG objects.

# Starts PRNG with random seed using specified sources (if any)
sub srand
{
    # Generalize for both OO and standalone PRNGs
    my $obj = (Scalar::Util::blessed($_[0])) ? shift : $MRMA::PRNG;

    if (@_) {
        # If sent seed by mistake, then send it to set_seed()
        if (Scalar::Util::looks_like_number($_[0]) || ref($_[0]) eq 'ARRAY') {
            $obj->set_seed(@_);
            return;
        }

        # Save specified sources
        $sources_for{$$obj} = shared_copy(\@_);
    }

    # Acquire seed from sources
    _acquire_seed($obj);

    # Seed the PRNG
    _seed_prng($obj);
}


# Return ref to PRNG's saved seed (if any)
sub get_seed
{
    # Generalize for both OO and standalone PRNGs
    my $obj = (Scalar::Util::blessed($_[0])) ? shift : $MRMA::PRNG;

    if (wantarray()) {
        return (@{$seed_for{$$obj}});
    }
    return ($seed_for{$$obj});
}


# Apply supplied seed, if given, to the PRNG,
sub set_seed
{
    # Generalize for both OO and standalone PRNGs
    my $obj = (Scalar::Util::blessed($_[0])) ? shift : $MRMA::PRNG;

    # Check argument
    if (! @_) {
        MRMA::Args->throw('message' => q/Missing argument to '->set_seed()'/);
    }

    # Save a copy of the seed
    if (ref($_[0]) eq 'ARRAY') {
        $seed_for{$$obj} = shared_copy($_[0]);
    } else {
        $seed_for{$$obj} = shared_copy(\@_);
    }

    # Seed the PRNG
    _seed_prng($obj);
}


# Return copy of PRNG's current state
sub get_state
{
    # Generalize for both OO and standalone PRNGs
    my $obj = (Scalar::Util::blessed($_[0])) ? shift : $MRMA::PRNG;

    if (wantarray()) {
        return (@{Math::Random::MT::Auto::_::get_state($obj)});
    }
    return (Math::Random::MT::Auto::_::get_state($obj));
}


# Set PRNG to supplied state
sub set_state
{
    # Generalize for both OO and standalone PRNGs
    my $obj = (Scalar::Util::blessed($_[0])) ? shift : $MRMA::PRNG;

    # Input can be array ref or array
    if (ref($_[0]) eq 'ARRAY') {
        Math::Random::MT::Auto::_::set_state($obj, $_[0]);
    } else {
        Math::Random::MT::Auto::_::set_state($obj, \@_);
    }
}


### Inside-out Object Internal Subroutines ###

# Object Constructor
sub _new_prng :ID
{
    return (Math::Random::MT::Auto::_::new_prng());
}

sub _clone_state :Replicate
{
    my ($from_obj, $to_obj) = @_;

    my $state = Math::Random::MT::Auto::_::get_state($from_obj);
    Math::Random::MT::Auto::_::set_state($to_obj, $state);
}

sub _free_prng :Destroy
{
    Math::Random::MT::Auto::_::free_prng(shift);
}

my %init_args :InitArgs = (
    'SOURCE' => {
        'REGEX'   => qr/^(?:source|src)s?$/i,
        'FIELD'   => \%sources_for,
        'TYPE'    => 'LIST',
    },
    'SEED' => {
        'REGEX'   => qr/^seed$/i,
        'DEFAULT' => [],
        'FIELD'   => \%seed_for,
        'TYPE'    => 'LIST',
    },
    'STATE' => {
        'REGEX'   => qr/^state$/i,
        'TYPE'    => 'ARRAY',
    },
);

# Object initializer - for internal use only
sub _init :Init
{
    my $self = $_[0];
    my $args = $_[1];   # Hash ref containing arguments from object
                        # constructor as specified by %init_args above

    # If no sources specified, then use default sources from standalone PRNG
    if (! exists($sources_for{$$self})) {
        my @srcs = @{$sources_for{$$MRMA::PRNG}};
        $self->set(\%sources_for, \@srcs);
    }

    # If state is specified, then use it
    if (exists($args->{'STATE'})) {
        $self->set_state($args->{'STATE'});

    } else {
        # Acquire seed, if none provided
        if (! @{$seed_for{$$self}}) {
            _acquire_seed($self);
        }

        # Seed the PRNG
        _seed_prng($self);
    }
}


### Overloading ###

sub as_string :Stringify :Numerify
{
    return ($_[0]->irand());
}

sub bool :Boolify
{
    return ($_[0]->irand() & 1);
}

sub array :Arrayify
{
    my $self  = $_[0];
    my $count = $_[1] || 1;

    my @ary;
    do {
        push(@ary, $self->irand());
    } while (--$count > 0);

    return (\@ary);
}

sub _code :Codify
{
    my $self = $_[0];
    return (sub { $self->irand(); });
}


### Serialization ###

# Support for ->dump() method
sub _dump :DUMPER
{
    my $obj = shift;

    my @seed    = @{$seed_for{$$obj}};
    # Must filter out code refs from sources
    my @sources = grep { ref($_) ne 'CODE' } @{$sources_for{$$obj}};
    my @state   = $obj->get_state();

    return ({
                'SOURCES' => \@sources,
                'SEED'    => \@seed,
                'STATE'   => \@state,
            });
}

# Support for Object::InsideOut::pump()
sub _pump :PUMPER
{
    my ($obj, $data) = @_;

    $obj->set(\%sources_for, $$data{'SOURCES'});
    $obj->set(\%seed_for,    $$data{'SEED'});
    $obj->set_state($$data{'STATE'});
}


### Internal Subroutines ###

# Constants #

# Size of Perl's integers (32- or 64-bit) and corresponding unpack code
require Config;
my $INT_SIZE    = $Config::Config{'uvsize'};
my $UNPACK_CODE = ($INT_SIZE == 8) ? 'Q' : 'L';
# Number of ints for a full 19968-bit seed
my $FULL_SEED   = 2496 / $INT_SIZE;


# If Windows XP and Win32::API, then make 'win32' a valid source
if (($^O eq 'MSWin32') || ($^O eq 'cygwin')) {
    eval { require Win32; };
    if (! $@) {
        my ($id, $major, $minor) = (Win32::GetOSVersion())[4,1,2];
        if (defined($minor) &&
            (($id > 2) ||
             ($id == 2 && $major > 5) ||
             ($id == 2 && $major == 5 && $minor >= 1)))
        {
            eval {
                # Suppress (harmless) warning about Win32::API::Type's INIT block
                local $SIG{__WARN__} = sub {
                    if ($_[0] !~ /^Too late to run INIT block/) {
                        print(STDERR "$_[0]\n");    # Output other warnings
                    }
                };

                require Win32::API;
            };
            if (! $@) {
                $DISPATCH{'win32'} = \&_acq_win32;
            }
        }
    }
}


# Acquire seed data from specific sources
sub _acquire_seed :PRIVATE
{
    my $prng    = $_[0];

    my $sources = $sources_for{$$prng};
    my $seed    = $seed_for{$$prng};

    # Acquire seed data until we have a full seed,
    # or until we run out of sources
    @{$seed} = ();
    for (my $ii=0;
         (@{$seed} < $FULL_SEED) && ($ii < @{$sources});
         $ii++)
    {
        my $src = $sources->[$ii];
        my $src_key = lc($src);   # Suitable as hash key

        # Determine amount of data needed
        my $need = $FULL_SEED - @{$seed};
        if (($ii+1 < @{$sources}) &&
            Scalar::Util::looks_like_number($sources->[$ii+1]))
        {
            if ($sources->[++$ii] < $need) {
                $need = $sources->[$ii];
            }
        }

        if (ref($src) eq 'CODE') {
            # User-supplied seeding subroutine
            $src->($seed, $need);

        } elsif (defined($DISPATCH{$src_key})) {
            # Module defined seeding source
            # Execute subroutine ref from dispatch table
            $DISPATCH{$src_key}->($src_key, $prng, $need);

        } elsif (-e $src) {
            # Random device or file
            $DISPATCH{'device'}->($src, $prng, $need);

        } else {
            Carp::carp("Unknown seeding source: $src");
        }
    }

    if (! @{$seed}) {
        # Complain about not getting any seed data, and provide a minimal seed
        Carp::carp('No seed data obtained from sources - Setting minimal seed using PID and time');
        push(@{$seed}, $$, time());

    } elsif (@{$seed} < $FULL_SEED) {
        # Complain about not getting a full seed
        Carp::carp('Partial seed - only ' . scalar(@{$seed}) . ' of ' . $FULL_SEED);
    }
}


# Acquire seed data from a device/file
sub _acq_device :PRIVATE
{
    my $device = $_[0];
    my $prng   = $_[1];
    my $need   = $_[2];

    # Try opening device/file
    my $FH;
    if (! open($FH, '<', $device)) {
        Carp::carp("Failure opening random device '$device': $!");
        return;
    }
    binmode($FH);

    # Try to set non-blocking mode (but not on Windows and Haiku)
    if ($^O ne 'MSWin32' && $^O ne 'Haiku') {
        eval {
            require Fcntl;

            my $flags;
            $flags = fcntl($FH, &Fcntl::F_GETFL, 0)
                or die("Failed getting filehandle flags: $!\n");
            fcntl($FH, &Fcntl::F_SETFL, $flags | &Fcntl::O_NONBLOCK)
                or die("Failed setting filehandle flags: $!\n");
        };
        if ($@) {
            Carp::carp("Failure setting non-blocking mode on random device '$device': $@");
        }
    }

    # Read data
    for (1..$need) {
        my $data;
        my $cnt = read($FH, $data, $INT_SIZE);

        if (defined($cnt)) {
            # Complain if we didn't get all the data we asked for
            if ($cnt < $INT_SIZE) {
                Carp::carp("Random device '$device' exhausted");
            }
            # Add data to seed array
            if ($cnt = int($cnt / $INT_SIZE)) {
                push(@{$seed_for{$$prng}}, unpack("$UNPACK_CODE$cnt", $data));
            }
        } else {
            Carp::carp("Failure reading from random device '$device': $!");
        }
    }
    close($FH);
}


# Cached LWP::UserAgent object
my $LWP_UA;

# Subroutine to acquire seed data from Internet sources
sub _acq_www :PRIVATE
{
    my $src  = $_[0];
    my $prng = $_[1];
    my $need = $_[2];

    # First, create user-agent object, if needed
    if (! $LWP_UA) {
        eval {
            require LWP::UserAgent;
            $LWP_UA = LWP::UserAgent->new('timeout' => 5, 'env_proxy' => 1);
        };
        if ($@) {
            Carp::carp("Failure creating user-agent: $@");
            return;
        }
    }

    ### Internal subroutines for processing Internet data

    # Process data from random.org
    my $random_org = sub {
        my $prng    = $_[0];
        my $content = $_[1];

        # Add data to seed array
        push(@{$seed_for{$$prng}}, unpack("$UNPACK_CODE*", $content));
    };

    # Process data from HotBits
    my $hotbits = sub {
        my $prng    = $_[0];
        my $content = $_[1];

        if ($content =~ /exceeded your 24-hour quota/) {
            # Complain about exceeding Hotbits quota
            Carp::carp('You have exceeded your 24-hour quota for HotBits.');
        } else {
            # Add data to seed array
            push(@{$seed_for{$$prng}}, unpack("$UNPACK_CODE*", $content));
        }
    };

    # Process data from RandomNumbers.info
    my $rn_info = sub {
        my $prng    = $_[0];
        my $content = $_[1];

        # Extract digits from web page
        my (@bytes) = $content =~ / ([\d]+)/g;
        # Make sure we have correct number of bytes for complete integers.
        # Also gets rid of copyright year that gets picked up from end of web page.
        do {
            pop(@bytes);
        } while (@bytes % $INT_SIZE);
        while (@bytes) {
            # Construct integers from bytes
            my $num = 0;
            for (1 .. $INT_SIZE) {
                $num = ($num << 8) + pop(@bytes);
            }
            # Add integer data to seed array
            push(@{$seed_for{$$prng}}, $num);
        }
    };

    ### Internet seed source information table
    my %www = (
        'random_org' => {
            'sitename'  => 'random.org',
            'URL'       => 'http://www.random.org/cgi-bin/randbyte?nbytes=',
            'max_bytes' => $FULL_SEED * $INT_SIZE,
            'processor' => $random_org
        },
        'hotbits' => {
            'sitename'  => 'HotBits',
            'URL'       => 'http://www.fourmilab.ch/cgi-bin/uncgi/Hotbits?fmt=bin&nbytes=',
            'max_bytes' => 2048,
            'processor' => $hotbits
        },
        'rn_info' => {
            'sitename'  => 'RandomNumbers.info',
            'URL'       => 'http://www.randomnumbers.info/cgibin/wqrng.cgi?limit=255&amount=',
            'max_bytes' => 1000,
            'processor' => $rn_info
        }
    );

    # Number of bytes to request (observing maximum data limit)
    my $bytes = $need * $INT_SIZE;
    if ($bytes > $www{$src}{'max_bytes'}) {
        $bytes = $www{$src}{'max_bytes'};
    }

    # Request the data
    my $res;
    eval {
        # Create request
        my $req = HTTP::Request->new('GET' => $www{$src}{'URL'} . $bytes);
        # Send the request
        $res = $LWP_UA->request($req);
    };

    # Handle the response
    if ($@) {
        Carp::carp("Failure contacting $www{$src}{'sitename'}: $@");
    } elsif ($res->is_success) {
        # Process the data
        $www{$src}{'processor'}->($prng, $res->content);
    } else {
        Carp::carp("Failure getting data from $www{$src}{'sitename'}: "
                                                    . $res->status_line);
    }
}


# Acquire seed data from Win XP random source
sub _acq_win32 :PRIVATE
{
    my $src   = $_[0];   # Not used
    my $prng  = $_[1];
    my $need  = $_[2];
    my $bytes = $need * $INT_SIZE;

    eval {
        # Import the random source function
        my $func = Win32::API->new('ADVAPI32.DLL',
                                   'SystemFunction036',
                                   'PN', 'I');
        if (! defined($func)) {
            die("Failure importing 'SystemFunction036': $!\n");
        }

        # Acquire the random data
        my $buffer = chr(0) x $bytes;
        if (! $func->Call($buffer, $bytes)) {
            die("'SystemFunction036' failed: $^E\n");
        }

        # Add data to seed array
        push(@{$seed_for{$$prng}}, unpack("$UNPACK_CODE*", $buffer));
    };
    if ($@) {
        Carp::carp("Failure acquiring Win XP random data: $@");
    }
}


# Seeds a PRNG
sub _seed_prng :PRIVATE
{
    my $prng = $_[0];

    my $seed = $seed_for{$$prng};   # Get the seed for the PRNG

    if ($Config::Config{'useithreads'} &&
        $threads::shared::threads_shared &&
        threads::shared::_id($seed))
    {
        # If the seed is thread-shared, then must make a non-shared copy to
        # send to the PRNG
        my @seed = @{$seed};
        Math::Random::MT::Auto::_::seed_prng($prng, \@seed);

    } else {
        # If no thread object sharing, then just send the seed
        Math::Random::MT::Auto::_::seed_prng($prng, $seed);
    }
}

}  # End of package's lexical scope

1;

__END__