162 lines
4.2 KiB
Perl
162 lines
4.2 KiB
Perl
package Test2::Plugin::SRand;
|
|
use strict;
|
|
use warnings;
|
|
|
|
our $VERSION = '0.000139';
|
|
|
|
use Carp qw/carp/;
|
|
|
|
use Test2::API qw{
|
|
context
|
|
test2_add_callback_post_load
|
|
test2_add_callback_exit
|
|
test2_stack
|
|
};
|
|
|
|
my $ADDED_HOOK = 0;
|
|
my $SEED;
|
|
my $FROM;
|
|
|
|
sub seed { $SEED }
|
|
sub from { $FROM }
|
|
|
|
sub import {
|
|
my $class = shift;
|
|
|
|
carp "SRand loaded multiple times, re-seeding rand"
|
|
if defined $SEED;
|
|
|
|
if (@_ == 1) {
|
|
($SEED) = @_;
|
|
$FROM = 'import arg';
|
|
}
|
|
elsif (@_ == 2 and $_[0] eq 'seed') {
|
|
$SEED = $_[1];
|
|
$FROM = 'import arg';
|
|
}
|
|
elsif(exists $ENV{T2_RAND_SEED}) {
|
|
$SEED = $ENV{T2_RAND_SEED};
|
|
$FROM = 'environment variable';
|
|
}
|
|
else {
|
|
my @ltime = localtime;
|
|
# Yes, this would be an awful seed if you actually wanted randomness.
|
|
# The idea here is that we want "random" behavior to be predictable
|
|
# within a given day. This allows you to reproduce failures that may or
|
|
# may not happen due to randomness.
|
|
$SEED = sprintf('%04d%02d%02d', 1900 + $ltime[5], 1 + $ltime[4], $ltime[3]);
|
|
$FROM = 'local date';
|
|
}
|
|
|
|
$SEED = 0 unless $SEED;
|
|
srand($SEED);
|
|
|
|
if ($ENV{HARNESS_IS_VERBOSE} || !$ENV{HARNESS_ACTIVE}) {
|
|
# If the harness is verbose then just display the message for all to
|
|
# see. It is nice info and they already asked for noisy output.
|
|
|
|
test2_add_callback_post_load(sub {
|
|
test2_stack()->top; # Ensure we have at least 1 hub.
|
|
my ($hub) = test2_stack()->all;
|
|
$hub->send(
|
|
Test2::Event::Note->new(
|
|
trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'SRAND']),
|
|
message => "Seeded srand with seed '$SEED' from $FROM.",
|
|
)
|
|
);
|
|
});
|
|
}
|
|
elsif (!$ADDED_HOOK++) {
|
|
# The seed can be important for debugging, so if anything is wrong we
|
|
# should output the seed message as a diagnostics message. This must be
|
|
# done at the very end, even later than a hub hook.
|
|
test2_add_callback_exit(
|
|
sub {
|
|
my ($ctx, $real, $new) = @_;
|
|
|
|
$ctx->diag("Seeded srand with seed '$SEED' from $FROM.")
|
|
if $real
|
|
|| ($new && $$new)
|
|
|| !$ctx->hub->is_passing;
|
|
}
|
|
);
|
|
}
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=pod
|
|
|
|
=encoding UTF-8
|
|
|
|
=head1 NAME
|
|
|
|
Test2::Plugin::SRand - Control the random seed for more controlled test
|
|
environments.
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This module gives you control over the random seed used for your unit tests. In
|
|
some testing environments the random seed can play a major role in results.
|
|
|
|
The default configuration for this module will seed srand with the local date.
|
|
Using the date as the seed means that on any given day the random seed will
|
|
always be the same, this means behavior will not change from run to run on a
|
|
given day. However the seed is different on different days allowing you to be
|
|
sure the code still works with actual randomness.
|
|
|
|
The seed is printed for you on failure, or when the harness is verbose. You can
|
|
use the C<T2_RAND_SEED> environment variable to specify the seed. You can also
|
|
provide a specific seed as a load-time argument to the plugin.
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
Loading the plugin is easy, and the defaults are sane:
|
|
|
|
use Test2::Plugin::SRand;
|
|
|
|
Custom seed:
|
|
|
|
use Test2::Plugin::SRand seed => 42;
|
|
|
|
=head1 NOTE ON LOAD ORDER
|
|
|
|
If you use this plugin you probably want to use it as the first, or near-first
|
|
plugin. C<srand> is not called until the plugin is loaded, so other plugins
|
|
loaded first may already be making use of random numbers before your seed
|
|
takes effect.
|
|
|
|
=head1 SOURCE
|
|
|
|
The source code repository for Test2-Suite can be found at
|
|
F<https://github.com/Test-More/Test2-Suite/>.
|
|
|
|
=head1 MAINTAINERS
|
|
|
|
=over 4
|
|
|
|
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
|
|
|
=back
|
|
|
|
=head1 AUTHORS
|
|
|
|
=over 4
|
|
|
|
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
|
|
|
=back
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>.
|
|
|
|
This program is free software; you can redistribute it and/or
|
|
modify it under the same terms as Perl itself.
|
|
|
|
See F<http://dev.perl.org/licenses/>
|
|
|
|
=cut
|