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


line stmt bran cond sub pod time code
1             package Math::Random::MT::Auto; {
2              
3             require 5.006;
4              
5 13     13   349946 use strict;
  13         76  
  13         400  
6 13     13   70 use warnings;
  13         24  
  13         908  
7              
8             our $VERSION = '6.23';
9             my $XS_VERSION = $VERSION;
10             $VERSION = eval $VERSION;
11              
12             require Carp;
13 13     13   83 use Scalar::Util 1.18;
  13         365  
  13         881  
14              
15             require XSLoader;
16             XSLoader::load('Math::Random::MT::Auto', $XS_VERSION);
17              
18 13     13   10769 use Object::InsideOut 2.06 ':hash_only';
  13         644245  
  13         78  
19 13     13   1581 use Object::InsideOut::Util 'shared_copy';
  13         29  
  13         80  
20              
21             # Exceptions thrown by this package
22             use Exception::Class (
23 13         127 'MRMA::Args' => {
24             'isa' => 'OIO::Args',
25             'description' =>
26             'Math::Random::MT::Auto exception that indicates an argument error',
27             },
28 13     13   1227 );
  13         32  
29              
30              
31             ### Inside-out Object Attributes ###
32              
33             # Object data is stored in these attribute hashes, and is keyed to the object
34             # by a unique ID that is stored in the object's scalar reference. For this
35             # class, that ID is the address of the PRNG's internal memory.
36             #
37             # These hashes are declared using the 'Field' attribute.
38              
39             my %sources_for :Field; # Sources from which to obtain random seed data
40             my %seed_for :Field; # Last seed sent to the PRNG
41              
42              
43             # Seed source subroutine dispatch table
44             my %DISPATCH = (
45             'device' => \&_acq_device,
46             'random_org' => \&_acq_www,
47             'hotbits' => \&_acq_www,
48             'rn_info' => \&_acq_www,
49             );
50              
51              
52             ### Module Initialization ###
53              
54             # Handle exportation of subroutine names, user-specified and default
55             # seeding sources. Also, auto-seeding of the standalone PRNG.
56             sub import
57             {
58 19     19   695 my $class = shift; # Not used
59              
60             # Exportable subroutines
61 19         37 my %EXPORT_OK;
62 19         103 @EXPORT_OK{qw(rand irand shuffle gaussian
63             exponential erlang poisson binomial
64             srand get_seed set_seed get_state set_state)} = undef;
65              
66 19         34 my $auto_seed = 1; # Flag to auto-seed the standalone PRNG
67              
68             # Handle entries in the import list
69 19         44 my $caller = caller();
70 19         35 my @sources;
71 19         68 while (my $sym = shift) {
72 38 100       145 if (exists($EXPORT_OK{lc($sym)})) {
    100          
73             # Export subroutine names
74 13     13   6267 no strict 'refs';
  13         29  
  13         9946  
75 26         43 *{$caller.'::'.$sym} = \&{lc($sym)};
  26         137  
  26         59  
76              
77             } elsif ($sym =~ /^:(no|!)?auto$/i) {
78             # To auto-seed (:auto is default) or not (:!auto or :noauto)
79 7         34 $auto_seed = not defined($1);
80              
81             } else {
82             # User-specified seed acquisition sources
83             # or user-defined seed acquisition subroutines
84 5         16 push(@sources, $sym);
85             # Add max. source count, if specified
86 5 50 33     27 if (@_ && Scalar::Util::looks_like_number($_[0])) {
87 0         0 push(@sources, shift);
88             }
89             }
90             }
91              
92             # Setup default sources, if needed
93 19 100       60 if (! @sources) {
94 14 50       254 if (exists($DISPATCH{'win32'})) {
    50          
    0          
95 0         0 push(@sources, 'win32');
96             } elsif (-e '/dev/urandom') {
97 14         57 push(@sources, '/dev/urandom');
98             } elsif (-e '/dev/random') {
99 0         0 push(@sources, '/dev/random');
100             }
101 14         23 push(@sources, 'random_org');
102             }
103              
104             # Create standalone PRNG
105 19 100       187 $MRMA::PRNG = Math::Random::MT::Auto->new(
106             'SOURCE' => \@sources,
107             ($auto_seed) ? () : ( 'SEED' => [ $$, time(), Scalar::Util::refaddr(\$VERSION) ] )
108             );
109             }
110              
111              
112             ### Dual-Interface (Functional and OO) Subroutines ###
113             #
114             # The subroutines below work both as regular 'functions' for the functional
115             # interface to the standalone PRNG, as well as methods for the OO interface
116             # to PRNG objects.
117              
118             # Starts PRNG with random seed using specified sources (if any)
119             sub srand
120             {
121             # Generalize for both OO and standalone PRNGs
122 1 50   1 1 1723 my $obj = (Scalar::Util::blessed($_[0])) ? shift : $MRMA::PRNG;
123              
124 1 50       4 if (@_) {
125             # If sent seed by mistake, then send it to set_seed()
126 1 50 33     13 if (Scalar::Util::looks_like_number($_[0]) || ref($_[0]) eq 'ARRAY') {
127 0         0 $obj->set_seed(@_);
128 0         0 return;
129             }
130              
131             # Save specified sources
132 1         6 $sources_for{$$obj} = shared_copy(\@_);
133             }
134              
135             # Acquire seed from sources
136 1         118 _acquire_seed($obj);
137              
138             # Seed the PRNG
139 1         54 _seed_prng($obj);
140             }
141              
142              
143             # Return ref to PRNG's saved seed (if any)
144             sub get_seed
145             {
146             # Generalize for both OO and standalone PRNGs
147 2 100   2 1 2256 my $obj = (Scalar::Util::blessed($_[0])) ? shift : $MRMA::PRNG;
148              
149 2 100       9 if (wantarray()) {
150 1         2 return (@{$seed_for{$$obj}});
  1         6  
151             }
152 1         7 return ($seed_for{$$obj});
153             }
154              
155              
156             # Apply supplied seed, if given, to the PRNG,
157             sub set_seed
158             {
159             # Generalize for both OO and standalone PRNGs
160 2 100   2 1 610 my $obj = (Scalar::Util::blessed($_[0])) ? shift : $MRMA::PRNG;
161              
162             # Check argument
163 2 50       9 if (! @_) {
164 0         0 MRMA::Args->throw('message' => q/Missing argument to '->set_seed()'/);
165             }
166              
167             # Save a copy of the seed
168 2 50       9 if (ref($_[0]) eq 'ARRAY') {
169 2         10 $seed_for{$$obj} = shared_copy($_[0]);
170             } else {
171 0         0 $seed_for{$$obj} = shared_copy(\@_);
172             }
173              
174             # Seed the PRNG
175 2         109 _seed_prng($obj);
176             }
177              
178              
179             # Return copy of PRNG's current state
180             sub get_state
181             {
182             # Generalize for both OO and standalone PRNGs
183 7 100   7 1 548006 my $obj = (Scalar::Util::blessed($_[0])) ? shift : $MRMA::PRNG;
184              
185 7 50       32 if (wantarray()) {
186 7         14 return (@{Math::Random::MT::Auto::_::get_state($obj)});
  7         376  
187             }
188 0         0 return (Math::Random::MT::Auto::_::get_state($obj));
189             }
190              
191              
192             # Set PRNG to supplied state
193             sub set_state
194             {
195             # Generalize for both OO and standalone PRNGs
196 6 100   6 1 25377 my $obj = (Scalar::Util::blessed($_[0])) ? shift : $MRMA::PRNG;
197              
198             # Input can be array ref or array
199 6 50       30 if (ref($_[0]) eq 'ARRAY') {
200 6         256 Math::Random::MT::Auto::_::set_state($obj, $_[0]);
201             } else {
202 0           Math::Random::MT::Auto::_::set_state($obj, \@_);
203             }
204             }
205              
206              
207             ### Inside-out Object Internal Subroutines ###
208              
209             # Object Constructor
210             sub _new_prng :ID
211             {
212 34         3988386 return (Math::Random::MT::Auto::_::new_prng());
213 13     13   107 }
  13         37  
  13         80  
214              
215             sub _clone_state :Replicate
216             {
217 2         192 my ($from_obj, $to_obj) = @_;
218              
219 2         63 my $state = Math::Random::MT::Auto::_::get_state($from_obj);
220 2         50 Math::Random::MT::Auto::_::set_state($to_obj, $state);
221 13     13   3642 }
  13         42  
  13         62  
222              
223             sub _free_prng :Destroy
224             {
225 21         3278560 Math::Random::MT::Auto::_::free_prng(shift);
226 13     13   2942 }
  13         29  
  13         60  
227              
228             my %init_args :InitArgs = (
229             'SOURCE' => {
230             'REGEX' => qr/^(?:source|src)s?$/i,
231             'FIELD' => \%sources_for,
232             'TYPE' => 'LIST',
233             },
234             'SEED' => {
235             'REGEX' => qr/^seed$/i,
236             'DEFAULT' => [],
237             'FIELD' => \%seed_for,
238             'TYPE' => 'LIST',
239             },
240             'STATE' => {
241             'REGEX' => qr/^state$/i,
242             'TYPE' => 'ARRAY',
243             },
244             );
245              
246             # Object initializer - for internal use only
247             sub _init :Init
248             {
249 30         14022 my $self = $_[0];
250 30         63 my $args = $_[1]; # Hash ref containing arguments from object
251             # constructor as specified by %init_args above
252              
253             # If no sources specified, then use default sources from standalone PRNG
254 30 100       141 if (! exists($sources_for{$$self})) {
255 10         26 my @srcs = @{$sources_for{$$MRMA::PRNG}};
  10         113  
256 10         41 $self->set(\%sources_for, \@srcs);
257             }
258              
259             # If state is specified, then use it
260 30 100       408 if (exists($args->{'STATE'})) {
261 1         4 $self->set_state($args->{'STATE'});
262              
263             } else {
264             # Acquire seed, if none provided
265 29 100       52 if (! @{$seed_for{$$self}}) {
  29         115  
266 18         89 _acquire_seed($self);
267             }
268              
269             # Seed the PRNG
270 29         157 _seed_prng($self);
271             }
272 13     13   5683 }
  13         29  
  13         61  
273              
274              
275             ### Overloading ###
276              
277             sub as_string :Stringify :Numerify
278             {
279 2     2 0 421 return ($_[0]->irand());
280 13     13   3029 }
  13         32  
  13         59  
281              
282             sub bool :Boolify
283             {
284 1     1 0 608 return ($_[0]->irand() & 1);
285 13     13   3367 }
  13         215  
  13         101  
286              
287             sub array :Arrayify
288             {
289 2     2 1 633 my $self = $_[0];
290 2   100     9 my $count = $_[1] || 1;
291              
292 2         3 my @ary;
293 2         4 do {
294 4         14 push(@ary, $self->irand());
295             } while (--$count > 0);
296              
297 2         9 return (\@ary);
298 13     13   3604 }
  13         31  
  13         52  
299              
300             sub _code :Codify
301             {
302 1     1   545 my $self = $_[0];
303 1     1   7 return (sub { $self->irand(); });
  1         9  
304 13     13   3124 }
  13         40  
  13         47  
305              
306              
307             ### Serialization ###
308              
309             # Support for ->dump() method
310             sub _dump :DUMPER
311             {
312 2         2950 my $obj = shift;
313              
314 2         5 my @seed = @{$seed_for{$$obj}};
  2         42  
315             # Must filter out code refs from sources
316 2         8 my @sources = grep { ref($_) ne 'CODE' } @{$sources_for{$$obj}};
  4         12  
  2         7  
317 2         13 my @state = $obj->get_state();
318              
319             return ({
320 2         24 'SOURCES' => \@sources,
321             'SEED' => \@seed,
322             'STATE' => \@state,
323             });
324 13     13   3990 }
  13         54  
  13         55  
325              
326             # Support for Object::InsideOut::pump()
327             sub _pump :PUMPER
328             {
329 2         52 my ($obj, $data) = @_;
330              
331 2         10 $obj->set(\%sources_for, $$data{'SOURCES'});
332 2         85 $obj->set(\%seed_for, $$data{'SEED'});
333 2         65 $obj->set_state($$data{'STATE'});
334 13     13   3454 }
  13         26  
  13         50  
335              
336              
337             ### Internal Subroutines ###
338              
339             # Constants #
340              
341             # Size of Perl's integers (32- or 64-bit) and corresponding unpack code
342             require Config;
343             my $INT_SIZE = $Config::Config{'uvsize'};
344             my $UNPACK_CODE = ($INT_SIZE == 8) ? 'Q' : 'L';
345             # Number of ints for a full 19968-bit seed
346             my $FULL_SEED = 2496 / $INT_SIZE;
347              
348              
349             # If Windows XP and Win32::API, then make 'win32' a valid source
350             if (($^O eq 'MSWin32') || ($^O eq 'cygwin')) {
351             eval { require Win32; };
352             if (! $@) {
353             my ($id, $major, $minor) = (Win32::GetOSVersion())[4,1,2];
354             if (defined($minor) &&
355             (($id > 2) ||
356             ($id == 2 && $major > 5) ||
357             ($id == 2 && $major == 5 && $minor >= 1)))
358             {
359             eval {
360             # Suppress (harmless) warning about Win32::API::Type's INIT block
361             local $SIG{__WARN__} = sub {
362             if ($_[0] !~ /^Too late to run INIT block/) {
363             print(STDERR "$_[0]\n"); # Output other warnings
364             }
365             };
366              
367             require Win32::API;
368             };
369             if (! $@) {
370             $DISPATCH{'win32'} = \&_acq_win32;
371             }
372             }
373             }
374             }
375              
376              
377             # Acquire seed data from specific sources
378             sub _acquire_seed :PRIVATE
379             {
380 19         226 my $prng = $_[0];
381              
382 19         59 my $sources = $sources_for{$$prng};
383 19         46 my $seed = $seed_for{$$prng};
384              
385             # Acquire seed data until we have a full seed,
386             # or until we run out of sources
387 19         53 @{$seed} = ();
  19         44  
388 19   100     382 for (my $ii=0;
389 38         214 (@{$seed} < $FULL_SEED) && ($ii < @{$sources});
  25         132  
390             $ii++)
391             {
392 19         148 my $src = $sources->[$ii];
393 19         56 my $src_key = lc($src); # Suitable as hash key
394              
395             # Determine amount of data needed
396 19         51 my $need = $FULL_SEED - @{$seed};
  19         61  
397 19 50 66     39 if (($ii+1 < @{$sources}) &&
  19         168  
398             Scalar::Util::looks_like_number($sources->[$ii+1]))
399             {
400 0 0       0 if ($sources->[++$ii] < $need) {
401 0         0 $need = $sources->[$ii];
402             }
403             }
404              
405 19 100       400 if (ref($src) eq 'CODE') {
    100          
    50          
406             # User-supplied seeding subroutine
407 1         4 $src->($seed, $need);
408              
409             } elsif (defined($DISPATCH{$src_key})) {
410             # Module defined seeding source
411             # Execute subroutine ref from dispatch table
412 3         18 $DISPATCH{$src_key}->($src_key, $prng, $need);
413              
414             } elsif (-e $src) {
415             # Random device or file
416 15         76 $DISPATCH{'device'}->($src, $prng, $need);
417              
418             } else {
419 0         0 Carp::carp("Unknown seeding source: $src");
420             }
421             }
422              
423 19 100       49 if (! @{$seed}) {
  19 100       80  
424             # Complain about not getting any seed data, and provide a minimal seed
425 4         476 Carp::carp('No seed data obtained from sources - Setting minimal seed using PID and time');
426 4         26 push(@{$seed}, $$, time());
  4         22  
427              
428 15         57 } elsif (@{$seed} < $FULL_SEED) {
429             # Complain about not getting a full seed
430 2         5 Carp::carp('Partial seed - only ' . scalar(@{$seed}) . ' of ' . $FULL_SEED);
  2         322  
431             }
432 13     13   9966 }
  13         36  
  13         57  
433              
434              
435             # Acquire seed data from a device/file
436             sub _acq_device :PRIVATE
437             {
438 15         37 my $device = $_[0];
439 15         68 my $prng = $_[1];
440 15         33 my $need = $_[2];
441              
442             # Try opening device/file
443 15         29 my $FH;
444 15 50       614 if (! open($FH, '<', $device)) {
445 0         0 Carp::carp("Failure opening random device '$device': $!");
446 0         0 return;
447             }
448 15         70 binmode($FH);
449              
450             # Try to set non-blocking mode (but not on Windows and Haiku)
451 15 50 33     124 if ($^O ne 'MSWin32' && $^O ne 'Haiku') {
452 15         35 eval {
453 15         113 require Fcntl;
454              
455 15         30 my $flags;
456 15 50       158 $flags = fcntl($FH, &Fcntl::F_GETFL, 0)
457             or die("Failed getting filehandle flags: $!\n");
458 15 50       200 fcntl($FH, &Fcntl::F_SETFL, $flags | &Fcntl::O_NONBLOCK)
459             or die("Failed setting filehandle flags: $!\n");
460             };
461 15 50       66 if ($@) {
462 0         0 Carp::carp("Failure setting non-blocking mode on random device '$device': $@");
463             }
464             }
465              
466             # Read data
467 15         58 for (1..$need) {
468 4680         8008 my $data;
469 4680         18775 my $cnt = read($FH, $data, $INT_SIZE);
470              
471 4680 100       8076 if (defined($cnt)) {
472             # Complain if we didn't get all the data we asked for
473 4368 100       7302 if ($cnt < $INT_SIZE) {
474 308         28289 Carp::carp("Random device '$device' exhausted");
475             }
476             # Add data to seed array
477 4368 100       15175 if ($cnt = int($cnt / $INT_SIZE)) {
478 4060         5402 push(@{$seed_for{$$prng}}, unpack("$UNPACK_CODE$cnt", $data));
  4060         10590  
479             }
480             } else {
481 312         35708 Carp::carp("Failure reading from random device '$device': $!");
482             }
483             }
484 15         313 close($FH);
485 13     13   7067 }
  13         31  
  13         55  
486              
487              
488             # Cached LWP::UserAgent object
489             my $LWP_UA;
490              
491             # Subroutine to acquire seed data from Internet sources
492             sub _acq_www :PRIVATE
493             {
494 3         6 my $src = $_[0];
495 3         5 my $prng = $_[1];
496 3         14 my $need = $_[2];
497              
498             # First, create user-agent object, if needed
499 3 50       9 if (! $LWP_UA) {
500 3         19 eval {
501 3         528 require LWP::UserAgent;
502 0         0 $LWP_UA = LWP::UserAgent->new('timeout' => 5, 'env_proxy' => 1);
503             };
504 3 50       2897 if ($@) {
505 3         27 Carp::carp("Failure creating user-agent: $@");
506 3         6540 return;
507             }
508             }
509              
510             ### Internal subroutines for processing Internet data
511              
512             # Process data from random.org
513             my $random_org = sub {
514 0         0 my $prng = $_[0];
515 0         0 my $content = $_[1];
516              
517             # Add data to seed array
518 0         0 push(@{$seed_for{$$prng}}, unpack("$UNPACK_CODE*", $content));
  0         0  
519 0         0 };
520              
521             # Process data from HotBits
522             my $hotbits = sub {
523 0         0 my $prng = $_[0];
524 0         0 my $content = $_[1];
525              
526 0 0       0 if ($content =~ /exceeded your 24-hour quota/) {
527             # Complain about exceeding Hotbits quota
528 0         0 Carp::carp('You have exceeded your 24-hour quota for HotBits.');
529             } else {
530             # Add data to seed array
531 0         0 push(@{$seed_for{$$prng}}, unpack("$UNPACK_CODE*", $content));
  0         0  
532             }
533 0         0 };
534              
535             # Process data from RandomNumbers.info
536             my $rn_info = sub {
537 0         0 my $prng = $_[0];
538 0         0 my $content = $_[1];
539              
540             # Extract digits from web page
541 0         0 my (@bytes) = $content =~ / ([\d]+)/g;
542             # Make sure we have correct number of bytes for complete integers.
543             # Also gets rid of copyright year that gets picked up from end of web page.
544 0         0 do {
545 0         0 pop(@bytes);
546             } while (@bytes % $INT_SIZE);
547 0         0 while (@bytes) {
548             # Construct integers from bytes
549 0         0 my $num = 0;
550 0         0 for (1 .. $INT_SIZE) {
551 0         0 $num = ($num << 8) + pop(@bytes);
552             }
553             # Add integer data to seed array
554 0         0 push(@{$seed_for{$$prng}}, $num);
  0         0  
555             }
556 0         0 };
557              
558             ### Internet seed source information table
559 0         0 my %www = (
560             'random_org' => {
561             'sitename' => 'random.org',
562             'URL' => 'http://www.random.org/cgi-bin/randbyte?nbytes=',
563             'max_bytes' => $FULL_SEED * $INT_SIZE,
564             'processor' => $random_org
565             },
566             'hotbits' => {
567             'sitename' => 'HotBits',
568             'URL' => 'http://www.fourmilab.ch/cgi-bin/uncgi/Hotbits?fmt=bin&nbytes=',
569             'max_bytes' => 2048,
570             'processor' => $hotbits
571             },
572             'rn_info' => {
573             'sitename' => 'RandomNumbers.info',
574             'URL' => 'http://www.randomnumbers.info/cgibin/wqrng.cgi?limit=255&amount=',
575             'max_bytes' => 1000,
576             'processor' => $rn_info
577             }
578             );
579              
580             # Number of bytes to request (observing maximum data limit)
581 0         0 my $bytes = $need * $INT_SIZE;
582 0 0       0 if ($bytes > $www{$src}{'max_bytes'}) {
583 0         0 $bytes = $www{$src}{'max_bytes'};
584             }
585              
586             # Request the data
587 0         0 my $res;
588 0         0 eval {
589             # Create request
590 0         0 my $req = HTTP::Request->new('GET' => $www{$src}{'URL'} . $bytes);
591             # Send the request
592 0         0 $res = $LWP_UA->request($req);
593             };
594              
595             # Handle the response
596 0 0       0 if ($@) {
    0          
597 0         0 Carp::carp("Failure contacting $www{$src}{'sitename'}: $@");
598             } elsif ($res->is_success) {
599             # Process the data
600 0         0 $www{$src}{'processor'}->($prng, $res->content);
601             } else {
602 0         0 Carp::carp("Failure getting data from $www{$src}{'sitename'}: "
603             . $res->status_line);
604             }
605 13     13   11945 }
  13         28  
  13         67  
606              
607              
608             # Acquire seed data from Win XP random source
609             sub _acq_win32 :PRIVATE
610             {
611 0         0 my $src = $_[0]; # Not used
612 0         0 my $prng = $_[1];
613 0         0 my $need = $_[2];
614 0         0 my $bytes = $need * $INT_SIZE;
615              
616 0         0 eval {
617             # Import the random source function
618 0         0 my $func = Win32::API->new('ADVAPI32.DLL',
619             'SystemFunction036',
620             'PN', 'I');
621 0 0       0 if (! defined($func)) {
622 0         0 die("Failure importing 'SystemFunction036': $!\n");
623             }
624              
625             # Acquire the random data
626 0         0 my $buffer = chr(0) x $bytes;
627 0 0       0 if (! $func->Call($buffer, $bytes)) {
628 0         0 die("'SystemFunction036' failed: $^E\n");
629             }
630              
631             # Add data to seed array
632 0         0 push(@{$seed_for{$$prng}}, unpack("$UNPACK_CODE*", $buffer));
  0         0  
633             };
634 0 0       0 if ($@) {
635 0         0 Carp::carp("Failure acquiring Win XP random data: $@");
636             }
637 13     13   5430 }
  13         76  
  13         54  
638              
639              
640             # Seeds a PRNG
641             sub _seed_prng :PRIVATE
642             {
643 32         398 my $prng = $_[0];
644              
645 32         88 my $seed = $seed_for{$$prng}; # Get the seed for the PRNG
646              
647 32 50 33     396 if ($Config::Config{'useithreads'} &&
      0        
648             $threads::shared::threads_shared &&
649             threads::shared::_id($seed))
650             {
651             # If the seed is thread-shared, then must make a non-shared copy to
652             # send to the PRNG
653 0         0 my @seed = @{$seed};
  0         0  
654 0         0 Math::Random::MT::Auto::_::seed_prng($prng, \@seed);
655              
656             } else {
657             # If no thread object sharing, then just send the seed
658 32         755 Math::Random::MT::Auto::_::seed_prng($prng, $seed);
659             }
660 13     13   3973 }
  13         34  
  13         188  
661              
662             } # End of package's lexical scope
663              
664             1;
665              
666             __END__