File Coverage

blib/lib/BSD/arc4random.pm

Criterion	Covered	Total	%
statement	45	79	56.9
branch	9	28	32.1
condition	3	9	33.3
subroutine	11	15	73.3
pod	7	7	100.0
total	75	138	54.3

# $MirOS: contrib/hosted/tg/code/BSD::arc4random/lib/BSD/arc4random.pm,v 1.10 2011/06/05 23:19:04 tg Exp $
#-
# Copyright (c) 2008, 2009, 2010, 2011
#	Thorsten Glaser
# Copyright (c) 2009
#	Benny Siegert
#
# Provided that these terms and disclaimer and all copyright notices
# are retained or reproduced in an accompanying document, permission
# is granted to deal in this work without restriction, including un-
# limited rights to use, publicly perform, distribute, sell, modify,
# merge, give away, or sublicence.
#
# This work is provided "AS IS" and WITHOUT WARRANTY of any kind, to
# the utmost extent permitted by applicable law, neither express nor
# implied; without malicious intent or gross negligence. In no event
# may a licensor, author or contributor be held liable for indirect,
# direct, other damage, loss, or other issues arising in any way out
# of dealing in the work, even if advised of the possibility of such
# damage or existence of a defect, except proven that it results out
# of said person's immediate fault when using the work as intended.

package BSD::arc4random;

use strict;
use warnings;

BEGIN {
	require Exporter;
	require DynaLoader;
	use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
	$VERSION = "1.50";
	@ISA = qw(Exporter DynaLoader);
	@EXPORT = qw();
	@EXPORT_OK = qw(
		$RANDOM
		&arc4random
		&arc4random_addrandom
		&arc4random_bytes
		&arc4random_pushb
		&arc4random_pushk
		&arc4random_stir
		&arc4random_uniform
	);
	%EXPORT_TAGS = (
		all => [ @EXPORT_OK ],
	);
}

use vars qw($RANDOM);		# public tied integer variable
sub have_kintf() {}		# public constant function, prototyped

my $have_threadlock = 1;
my $arcfour_lock;
eval { require threads::shared; };
if ($@) {
	$have_threadlock = 0;	# module not available
} else {
	# private thread lock
	threads::shared::share($arcfour_lock);
};

bootstrap BSD::arc4random $BSD::arc4random::VERSION;

# public thread-safe functions
sub
arc4random()
{
	lock($arcfour_lock) if $have_threadlock;
	return &arc4random_xs();
}

sub
arc4random_addrandom($)
{
	my $buf = shift;

	lock($arcfour_lock) if $have_threadlock;
	return &arc4random_addrandom_xs($buf);
}

sub
arc4random_pushb($)
{
	my $buf = shift;

	lock($arcfour_lock) if $have_threadlock;
	return &arc4random_pushb_xs($buf);
}

sub
arc4random_pushk($)
{
	my $buf = shift;

	lock($arcfour_lock) if $have_threadlock;
	return &arc4random_pushk_xs($buf);
}

sub
arc4random_stir()
{
	lock($arcfour_lock) if $have_threadlock;
	&arc4random_stir_xs();
	return;
}

sub
arc4random_bytes($;$)
{
	my ($len, $buf) = @_;
	my $val;
	my $vleft = 0;
	my $rv = '';
	my $idx = 0;

	if (defined($buf)) {
		$val = arc4random_pushb($buf);
		$vleft = 4;
	}
	while (($len - $idx) >= 4) {
		if ($vleft < 4) {
			$val = arc4random();
			$vleft = 4;
		}
		vec($rv, $idx / 4, 32) = $val;
		$idx += 4;
		$vleft = 0;
	}
	while ($idx < $len) {
		if ($vleft == 0) {
			$val = arc4random();
			$vleft = 4;
		}
		vec($rv, $idx, 8) = $val & 0xFF;
		$idx++;
		$val >>= 8;
		$vleft--;
	}
	return $rv;
}

# Perl implementation of arc4random_uniform(3)
# C implementation contributed by [e-mail], [e-mail]
#
# Calculate a uniformly distributed random number less than upper_bound
# avoiding "modulo bias".
#
# Uniformity is achieved by generating new random numbers until the one
# returned is outside the range [0, 2**32 % upper_bound).  This
# guarantees the selected random number will be inside
# [2**32 % upper_bound, 2**32) which maps back to [0, upper_bound)
# after reduction modulo upper_bound.

sub
arc4random_uniform($)
{
	my $upper_bound = shift;
	my $r;
	my $min;

	return 0 unless defined($upper_bound);
	# convert upper_bound to 32-bit UV (unsigned integer value)
	$upper_bound &= 0xFFFFFFFF;
	return 0 if $upper_bound < 2 || $upper_bound > 0xFFFFFFFF;

	# Calculate (2**32 % upper_bound) avoiding 64-bit math
	if ($upper_bound > 0x80000000) {
		# 2**32 - upper_bound (only one "value area")
		$min = 1 + (~$upper_bound & 0xFFFFFFFF);
	} else {
		# (2**32 - x) % x == 2**32 % x when x <= 2**31
		$min = (0xFFFFFFFF - $upper_bound + 1) % $upper_bound;
	}

	# This could theoretically loop forever but each retry has
	# p > 0.5 (worst case, usually far better) of selecting a
	# number inside the range we need, so it should rarely need
	# to re-roll.
	while (1) {
		$r = arc4random();
		last if $r >= $min;
	}

	return ($r % $upper_bound);
}

# private implementation for a tied $RANDOM variable
sub
TIESCALAR
{
	my $class = shift;
	my $max = shift;

	if (!defined($max) || ($max = int($max)) > 0xFFFFFFFE || $max < 0) {
		$max = 0;
	}

	return bless \$max, $class;
}

sub
FETCH
{
	my $self = shift;

	return ($$self == 0 ? arc4random() : arc4random_uniform($$self + 1));
}

sub
STORE
{
	my $self = shift;
	my $value = shift;

	arc4random_pushb($value);
}

# tie the public $RANDOM variable to an mksh-style implementation
tie $RANDOM, 'BSD::arc4random', 0x7FFF;

# we are nice and re-seed perl's internal PRNG as well
srand(arc4random_pushb(pack("F*", rand(), rand(), rand(), rand())));

1;
__END__