From cbc31669fc9877189237508f7d2a0d8f5f840833 Mon Sep 17 00:00:00 2001 From: Packit Date: Sep 16 2020 15:16:51 +0000 Subject: perl-Parallel-ForkManager-1.19 base --- diff --git a/CONTRIBUTORS b/CONTRIBUTORS new file mode 100644 index 0000000..07338b5 --- /dev/null +++ b/CONTRIBUTORS @@ -0,0 +1,12 @@ + +# PARALLEL-FORKMANAGER CONTRIBUTORS # + +This is the (likely incomplete) list of people who have helped +make this distribution what it is, either via code contributions, +patches, bug reports, help with troubleshooting, etc. A huge +'thank you' to all of them. + + * Ninebit + * Shlomi Fish + + diff --git a/Changes b/Changes new file mode 100644 index 0000000..1e2275f --- /dev/null +++ b/Changes @@ -0,0 +1,153 @@ +Revision history for Perl extension Parallel::ForkManager. + +1.19 2016-06-28 + [ DOCUMENTATION ] + - Typo fixes. (GH#10) + - Add short discussion on security about the information passing via + files between master/children processes. + - Document the problem between PerlIO::fzip and fork(). (GH#11) + + [ ENHANCEMENTS ] + - New way to spawn workers via 'start_child'. + + [ STATISTICS ] + - code churn: 4 files changed, 114 insertions(+), 5 deletions(-) + +1.18 2016-03-29 + [ BUG FIXES ] + - Storage file between child and parent could have the wrong name, + because $$ was used instead of parent_pid. (GH#9, reported by Lucien + Coffe) + + [ STATISTICS ] + - code churn: 4 files changed, 37 insertions(+), 4 deletions(-) + +1.17 2015-11-28 + - Up Test::More's dependency version to v0.94 (because of 'subtest'). + (GH#8, mauke) + + [ STATISTICS ] + - code churn: 3 files changed, 88 insertions(+), 70 deletions(-) + +1.16 2015-10-08 + - wait_one_child wasn't waiting at all. (RT#107634, Slaven Rezic, Yanick) + + [ STATISTICS ] + - code churn: 10 files changed, 517 insertions(+), 461 deletions(-) + +1.15 2015-07-08 + - test's watchdog actually exit if it's being hit. (RT#105747, Zefram) + - condition to catch children reaped by external forces improved. + (RT#105748, Zefram + Yanick) + +1.14 2015-05-17 + - Add 'reap_finished_children', 'is_child' and 'is_parent'. (GH#6, Nine + bit) + +1.13 2015-05-11 + - Use 'select' instead of sleep in _waitpid_blocking. (GH#5) + +1.12 2015-02-23 + - Allow to use true blocking calls. (RT#102305) + +1.11 2015-01-30 + - Promote to non-dev release. + +1.10_2 2015-01-25 + - Put the problematic test as a TODO. + +1.10_1 2015-01-22 + - Increase timeouts in test to address FreeBSD failures. + +1.09 2015-01-08 + - Test was failing on Windows platforms. (Yanick Champoux) + +1.08 2015-01-07 + - New helper functions 'max_procs', 'running_procs' and + 'wait_for_available_procs'. GH#4 (Yanick Champoux) + - Play nicer with calls to 'waitpid' done outside of P::FM. GH#3 (Yanick + Champoux) + +1.07 2014-11-10 + - Increase minimal Test::Simple requirement RT #92801 + - Implement better style and practices in the examples in the POD. + (Shlomi Fish) + +1.06 2013-12-24 + - Remove temporary directory only if it was an automatically generated + one. Now fixed. (Shoichi Kaji) RT #89590 (johantheolive) + +1.05 2013-09-18 + - Remove temporary directory only if it was an automatically generated + one. (reported by Manuel Jeckelmann) + +1.04 2013-09-03 + - Require File::Path 2.0 to support Perl 5.8 (Ian Burrell) + - fix some typos #88358 (David Steinbrunner) + - documentation fixes #84337 (Damyan Ivanov) + +1.03 2013-03-06 + - Use second parameter from new() that was unused in the last few + released. (Michael Gang) + +1.02 2012-12-24 + - Fix test for Windows. + +1.01 2012-12-23 + - Disable utf8 test on Windows where it is a perl bug. + - Change version number scheme to two parts. + +1.0.0 2012-12-23 + - Fixing RT 68298 - Insecure /tmp file handling using File::Temp::tempdir + by John Lightsey (LIGHTSEY) + - Adding another callback example and several tests Gabor Szabo (SZABGAB) + +0.7 2001-04-04 + - callback code tested, exit status return (Chuck, dLux) + - added parallel_get.pl, a parallel webget example (dLux) + - added callbacks.pl, a callback example (Chuck, dLux) + - documentation updtes (Chuck, dLux) + +0.6 2000-11-30 + - documentation tweak fixes by Noah Robin + - warning elimination fixes + +0.5 2000-10-18 + - original version; created by h2xs 1.19 + +0.7.9 2010-11-01 + - Exclude the example scripts from getting installed. + (https://rt.cpan.org/Public/Bug/Display.html?id=62506) + +0.7.8 2010-08-25 + - Make $VERSION compatible with the most perl versions possible + (http://rt.cpan.org/Public/Bug/Display.html?id=62180) + +0.7.7 2010-09-28 + - Small distribution fixes + +0.7.6 2010-08-15 + - Added datastructure retrieval (Ken Clarke) + - Using CORE::exit instead of exit + (http://rt.cpan.org/Public/Bug/Display.html?id=39003) + +0.7.5 2002-12-25 + - Documentation fixes + - Fix bug if you specify max_procs = 0 + +0.7.4 2002-07-04 + - on_wait callback now runs from the wait_all_children method + - run_on_wait can run a task periodically, not only once. + +0.7.3 2001-08-24 + - minor bugfix on calling the "on_finish" callback + +0.7.2 2001-05-14 + - win32 port + - fix for the broken wait_one_child + +0.7.1 2001-04-26 + - various semantical and grammar fixes in the documentation + - on_finish now get the exit signal also + - on_start now get the process-identification also + - described limitations in the doc diff --git a/INSTALL b/INSTALL new file mode 100644 index 0000000..af77424 --- /dev/null +++ b/INSTALL @@ -0,0 +1,43 @@ +This is the Perl distribution Parallel-ForkManager. + +Installing Parallel-ForkManager is straightforward. + +## Installation with cpanm + +If you have cpanm, you only need one line: + + % cpanm Parallel::ForkManager + +If you are installing into a system-wide directory, you may need to pass the +"-S" flag to cpanm, which uses sudo to install the module: + + % cpanm -S Parallel::ForkManager + +## Installing with the CPAN shell + +Alternatively, if your CPAN shell is set up, you should just be able to do: + + % cpan Parallel::ForkManager + +## Manual installation + +As a last resort, you can manually install it. Download the tarball, untar it, +then build it: + + % perl Makefile.PL + % make && make test + +Then install it: + + % make install + +If you are installing into a system-wide directory, you may need to run: + + % sudo make install + +## Documentation + +Parallel-ForkManager documentation is available as POD. +You can run perldoc from a shell to read the documentation: + + % perldoc Parallel::ForkManager diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..afe82d9 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,32 @@ +CONTRIBUTORS +Changes +INSTALL +MANIFEST +META.json +META.yml +Makefile.PL +README.mkdn +SIGNATURE +cpanfile +doap.xml +examples/callback.pl +examples/callback_data.pl +examples/parallel_get.pl +lib/Parallel/ForkManager.pm +t/00-compile.t +t/00-load.t +t/00-report-prereqs.dd +t/00-report-prereqs.t +t/01-utf8-all.t +t/02-callback.t +t/03-callback-data.t +t/basic-methods.t +t/callback.txt +t/callback_data.txt +t/changing-pids.t +t/start_child.t +t/waitpid-conflict.t +t/waitpid-waitonechild.t +t/waitpid_blocking.t +xt/release/pause-permissions.t +xt/release/unused-vars.t diff --git a/META.json b/META.json new file mode 100644 index 0000000..962a87f --- /dev/null +++ b/META.json @@ -0,0 +1,84 @@ +{ + "abstract" : "A simple parallel processing fork manager", + "author" : [ + "dLux (Szabó, Balázs) ", + "Yanick Champoux ", + "Gabor Szabo " + ], + "dynamic_config" : 0, + "generated_by" : "Dist::Zilla version 5.043, CPAN::Meta::Converter version 2.150001", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "Parallel-ForkManager", + "prereqs" : { + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "develop" : { + "requires" : { + "Test::More" : "0.96", + "Test::PAUSE::Permissions" : "0", + "Test::Vars" : "0", + "warnings" : "0" + } + }, + "runtime" : { + "requires" : { + "Carp" : "0", + "File::Path" : "0", + "File::Spec" : "0", + "File::Temp" : "0", + "POSIX" : "0", + "Storable" : "0", + "strict" : "0" + } + }, + "test" : { + "recommends" : { + "CPAN::Meta" : "2.120900" + }, + "requires" : { + "ExtUtils::MakeMaker" : "0", + "File::Spec" : "0", + "IO::Handle" : "0", + "IPC::Open3" : "0", + "Test::More" : "0.94", + "Test::Warn" : "0", + "perl" : "5.006", + "warnings" : "0" + } + } + }, + "provides" : { + "Parallel::ForkManager" : { + "file" : "lib/Parallel/ForkManager.pm", + "version" : "1.19" + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "web" : "https://github.com/dluxhu/perl-parallel-forkmanager/issues" + }, + "homepage" : "https://github.com/dluxhu/perl-parallel-forkmanager", + "repository" : { + "type" : "git", + "url" : "https://github.com/dluxhu/perl-parallel-forkmanager.git", + "web" : "https://github.com/dluxhu/perl-parallel-forkmanager" + } + }, + "version" : "1.19", + "x_authority" : "cpan:DLUX", + "x_contributors" : [ + "Ninebit ", + "Shlomi Fish " + ] +} + diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..e1e90d7 --- /dev/null +++ b/META.yml @@ -0,0 +1,45 @@ +--- +abstract: 'A simple parallel processing fork manager' +author: + - 'dLux (Szabó, Balázs) ' + - 'Yanick Champoux ' + - 'Gabor Szabo ' +build_requires: + ExtUtils::MakeMaker: '0' + File::Spec: '0' + IO::Handle: '0' + IPC::Open3: '0' + Test::More: '0.94' + Test::Warn: '0' + perl: '5.006' + warnings: '0' +configure_requires: + ExtUtils::MakeMaker: '0' +dynamic_config: 0 +generated_by: 'Dist::Zilla version 5.043, CPAN::Meta::Converter version 2.150001' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: Parallel-ForkManager +provides: + Parallel::ForkManager: + file: lib/Parallel/ForkManager.pm + version: '1.19' +requires: + Carp: '0' + File::Path: '0' + File::Spec: '0' + File::Temp: '0' + POSIX: '0' + Storable: '0' + strict: '0' +resources: + bugtracker: https://github.com/dluxhu/perl-parallel-forkmanager/issues + homepage: https://github.com/dluxhu/perl-parallel-forkmanager + repository: https://github.com/dluxhu/perl-parallel-forkmanager.git +version: '1.19' +x_authority: cpan:DLUX +x_contributors: + - 'Ninebit ' + - 'Shlomi Fish ' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..e6bc508 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,70 @@ +# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v5.043. +use strict; +use warnings; + +use 5.006; + +use ExtUtils::MakeMaker; + +my %WriteMakefileArgs = ( + "ABSTRACT" => "A simple parallel processing fork manager", + "AUTHOR" => "dLux (Szab\x{f3}, Bal\x{e1}zs) , Yanick Champoux , Gabor Szabo ", + "CONFIGURE_REQUIRES" => { + "ExtUtils::MakeMaker" => 0 + }, + "DISTNAME" => "Parallel-ForkManager", + "LICENSE" => "perl", + "MIN_PERL_VERSION" => "5.006", + "NAME" => "Parallel::ForkManager", + "PREREQ_PM" => { + "Carp" => 0, + "File::Path" => 0, + "File::Spec" => 0, + "File::Temp" => 0, + "POSIX" => 0, + "Storable" => 0, + "strict" => 0 + }, + "TEST_REQUIRES" => { + "ExtUtils::MakeMaker" => 0, + "File::Spec" => 0, + "IO::Handle" => 0, + "IPC::Open3" => 0, + "Test::More" => "0.94", + "Test::Warn" => 0, + "warnings" => 0 + }, + "VERSION" => "1.19", + "test" => { + "TESTS" => "t/*.t" + } +); + + +my %FallbackPrereqs = ( + "Carp" => 0, + "ExtUtils::MakeMaker" => 0, + "File::Path" => 0, + "File::Spec" => 0, + "File::Temp" => 0, + "IO::Handle" => 0, + "IPC::Open3" => 0, + "POSIX" => 0, + "Storable" => 0, + "Test::More" => "0.94", + "Test::Warn" => 0, + "strict" => 0, + "warnings" => 0 +); + + +unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { + delete $WriteMakefileArgs{TEST_REQUIRES}; + delete $WriteMakefileArgs{BUILD_REQUIRES}; + $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; +} + +delete $WriteMakefileArgs{CONFIGURE_REQUIRES} + unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; + +WriteMakefile(%WriteMakefileArgs); diff --git a/README.mkdn b/README.mkdn new file mode 100644 index 0000000..802abf7 --- /dev/null +++ b/README.mkdn @@ -0,0 +1,565 @@ +# NAME + +Parallel::ForkManager - A simple parallel processing fork manager + +# VERSION + +version 1.19 + +# SYNOPSIS + + use Parallel::ForkManager; + + my $pm = Parallel::ForkManager->new($MAX_PROCESSES); + + DATA_LOOP: + foreach my $data (@all_data) { + # Forks and returns the pid for the child: + my $pid = $pm->start and next DATA_LOOP; + + ... do some work with $data in the child process ... + + $pm->finish; # Terminates the child process + } + +# DESCRIPTION + +This module is intended for use in operations that can be done in parallel +where the number of processes to be forked off should be limited. Typical +use is a downloader which will be retrieving hundreds/thousands of files. + +The code for a downloader would look something like this: + + use LWP::Simple; + use Parallel::ForkManager; + + ... + + my @links=( + ["http://www.foo.bar/rulez.data","rulez_data.txt"], + ["http://new.host/more_data.doc","more_data.doc"], + ... + ); + + ... + + # Max 30 processes for parallel download + my $pm = Parallel::ForkManager->new(30); + + LINKS: + foreach my $linkarray (@links) { + $pm->start and next LINKS; # do the fork + + my ($link, $fn) = @$linkarray; + warn "Cannot get $fn from $link" + if getstore($link, $fn) != RC_OK; + + $pm->finish; # do the exit in the child process + } + $pm->wait_all_children; + +First you need to instantiate the ForkManager with the "new" constructor. +You must specify the maximum number of processes to be created. If you +specify 0, then NO fork will be done; this is good for debugging purposes. + +Next, use $pm->start to do the fork. $pm returns 0 for the child process, +and child pid for the parent process (see also ["fork()" in perlfunc(1p)](http://man.he.net/man1p/perlfunc)). +The "and next" skips the internal loop in the parent process. NOTE: +$pm->start dies if the fork fails. + +$pm->finish terminates the child process (assuming a fork was done in the +"start"). + +NOTE: You cannot use $pm->start if you are already in the child process. +If you want to manage another set of subprocesses in the child process, +you must instantiate another Parallel::ForkManager object! + +# METHODS + +The comment letter indicates where the method should be run. P for parent, +C for child. + +- new $processes + + Instantiate a new Parallel::ForkManager object. You must specify the maximum + number of children to fork off. If you specify 0 (zero), then no children + will be forked. This is intended for debugging purposes. + + The optional second parameter, $tempdir, is only used if you want the + children to send back a reference to some data (see RETRIEVING DATASTRUCTURES + below). If not provided, it is set via a call to [File::Temp](https://metacpan.org/pod/File::Temp)::tempdir(). + + The new method will die if the temporary directory does not exist or it is not + a directory. + +- start \[ $process\_identifier \] + + This method does the fork. It returns the pid of the child process for + the parent, and 0 for the child process. If the $processes parameter + for the constructor is 0 then, assuming you're in the child process, + $pm->start simply returns 0. + + An optional $process\_identifier can be provided to this method... It is used by + the "run\_on\_finish" callback (see CALLBACKS) for identifying the finished + process. + +- start\_child \[ $process\_identifier, \] \\&callback + + Like `start`, but will run the `&callback` as the child. If the callback returns anything, + it'll be passed as the data to transmit back to the parent process via `finish()`. + +- finish \[ $exit\_code \[, $data\_structure\_reference\] \] + + Closes the child process by exiting and accepts an optional exit code + (default exit code is 0) which can be retrieved in the parent via callback. + If the second optional parameter is provided, the child attempts to send + its contents back to the parent. If you use the program in debug mode + ($processes == 0), this method just calls the callback. + + If the $data\_structure\_reference is provided, then it is serialized and + passed to the parent process. See RETRIEVING DATASTRUCTURES for more info. + +- set\_max\_procs $processes + + Allows you to set a new maximum number of children to maintain. + +- wait\_all\_children + + You can call this method to wait for all the processes which have been + forked. This is a blocking wait. + +- reap\_finished\_children + + This is a non-blocking call to reap children and execute callbacks independent + of calls to "start" or "wait\_all\_children". Use this in scenarios where "start" + is called infrequently but you would like the callbacks executed quickly. + +- is\_parent + + Returns `true` if within the parent or `false` if within the child. + +- is\_child + + Returns `true` if within the child or `false` if within the parent. + +- max\_procs + + Returns the maximal number of processes the object will fork. + +- running\_procs + + Returns the pids of the forked processes currently monitored by the + `Parallel::ForkManager`. Note that children are still reported as running + until the fork manager harvest them, via the next call to + `start` or `wait_all_children`. + + my @pids = $pm->running_procs; + + my $nbr_children =- $pm->running_procs; + +- wait\_for\_available\_procs( $n ) + + Wait until `$n` available process slots are available. + If `$n` is not given, defaults to _1_. + +- waitpid\_blocking\_sleep + + Returns the sleep period, in seconds, of the pseudo-blocking calls. The sleep + period can be a fraction of second. + + Returns `0` if disabled. + + Defaults to 1 second. + + See _BLOCKING CALLS_ for more details. + +- set\_waitpid\_blocking\_sleep $seconds + + Sets the the sleep period, in seconds, of the pseudo-blocking calls. + Set to `0` to disable. + + See _BLOCKING CALLS_ for more details. + +# CALLBACKS + +You can define callbacks in the code, which are called on events like starting +a process or upon finish. Declare these before the first call to start(). + +The callbacks can be defined with the following methods: + +- run\_on\_finish $code \[, $pid \] + + You can define a subroutine which is called when a child is terminated. It is + called in the parent process. + + The parameters of the $code are the following: + + - pid of the process, which is terminated + - exit code of the program + - identification of the process (if provided in the "start" method) + - exit signal (0-127: signal name) + - core dump (1 if there was core dump at exit) + - datastructure reference or undef (see RETRIEVING DATASTRUCTURES) + +- run\_on\_start $code + + You can define a subroutine which is called when a child is started. It called + after the successful startup of a child in the parent process. + + The parameters of the $code are the following: + + - pid of the process which has been started + - identification of the process (if provided in the "start" method) + +- run\_on\_wait $code, \[$period\] + + You can define a subroutine which is called when the child process needs to wait + for the startup. If $period is not defined, then one call is done per + child. If $period is defined, then $code is called periodically and the + module waits for $period seconds between the two calls. Note, $period can be + fractional number also. The exact "$period seconds" is not guaranteed, + signals can shorten and the process scheduler can make it longer (on busy + systems). + + The $code called in the "start" and the "wait\_all\_children" method also. + + No parameters are passed to the $code on the call. + +# BLOCKING CALLS + +When it comes to waiting for child processes to terminate, `Parallel::ForkManager` is between +a fork and a hard place (if you excuse the terrible pun). The underlying Perl `waitpid` function +that the module relies on can block until either one specific or any child process +terminate, but not for a process part of a given group. + +This means that the module can do one of two things when it waits for +one of its child processes to terminate: + +- Only wait for its own child processes + + This is done via a loop using a `waitpid` non-blocking call and a sleep statement. + The code does something along the lines of + + while(1) { + if ( any of the P::FM child process terminated ) { + return its pid + } + + sleep $sleep_period + } + + This is the default behavior that the module will use. + This is not the most efficient way to wait for child processes, but it's + the safest way to ensure that `Parallel::ForkManager` won't interfere with + any other part of the codebase. + + The sleep period is set via the method `set_waitpid_blocking_sleep`. + +- Block until any process terminate + + Alternatively, `Parallel::ForkManager` can call `waitpid` such that it will + block until any child process terminate. If the child process was not one of + the monitored subprocesses, the wait will resume. This is more efficient, but mean + that `P::FM` can captures (and discards) the termination notification that a different + part of the code might be waiting for. + + If this is a race condition + that doesn't apply to your codebase, you can set the + _waitpid\_blocking\_sleep_ period to `0`, which will enable `waitpid` call blocking. + + my $pm = Parallel::ForkManager->new( 4 ); + + $pm->set_waitpid_blocking_sleep(0); # true blocking calls enabled + + for ( 1..100 ) { + $pm->start and next; + + ...; # do work + + $pm->finish; + } + +# RETRIEVING DATASTRUCTURES from child processes + +The ability for the parent to retrieve data structures is new as of version +0.7.6. + +Each child process may optionally send 1 data structure back to the parent. +By data structure, we mean a reference to a string, hash or array. The +contents of the data structure are written out to temporary files on disc +using the [Storable](https://metacpan.org/pod/Storable) modules' store() method. The reference is then +retrieved from within the code you send to the run\_on\_finish callback. + +The data structure can be any scalar perl data structure which makes sense: +string, numeric value or a reference to an array, hash or object. + +There are 2 steps involved in retrieving data structures: + +1) A reference to the data structure the child wishes to send back to the +parent is provided as the second argument to the finish() call. It is up +to the child to decide whether or not to send anything back to the parent. + +2) The data structure reference is retrieved using the callback provided in +the run\_on\_finish() method. + +Keep in mind that data structure retrieval is not the same as returning a +data structure from a method call. That is not what actually occurs. The +data structure referenced in a given child process is serialized and +written out to a file by [Storable](https://metacpan.org/pod/Storable). The file is subsequently read back +into memory and a new data structure belonging to the parent process is +created. Please consider the performance penalty it can imply, so try to +keep the returned structure small. + +# EXAMPLES + +## Parallel get + +This small example can be used to get URLs in parallel. + + use Parallel::ForkManager; + use LWP::Simple; + + my $pm = Parallel::ForkManager->new(10); + + LINKS: + for my $link (@ARGV) { + $pm->start and next LINKS; + my ($fn) = $link =~ /^.*\/(.*?)$/; + if (!$fn) { + warn "Cannot determine filename from $fn\n"; + } else { + $0 .= " " . $fn; + print "Getting $fn from $link\n"; + my $rc = getstore($link, $fn); + print "$link downloaded. response code: $rc\n"; + }; + $pm->finish; + }; + +## Callbacks + +Example of a program using callbacks to get child exit codes: + + use strict; + use Parallel::ForkManager; + + my $max_procs = 5; + my @names = qw( Fred Jim Lily Steve Jessica Bob Dave Christine Rico Sara ); + # hash to resolve PID's back to child specific information + + my $pm = Parallel::ForkManager->new($max_procs); + + # Setup a callback for when a child finishes up so we can + # get it's exit code + $pm->run_on_finish( sub { + my ($pid, $exit_code, $ident) = @_; + print "** $ident just got out of the pool ". + "with PID $pid and exit code: $exit_code\n"; + }); + + $pm->run_on_start( sub { + my ($pid, $ident)=@_; + print "** $ident started, pid: $pid\n"; + }); + + $pm->run_on_wait( sub { + print "** Have to wait for one children ...\n" + }, + 0.5 + ); + + NAMES: + foreach my $child ( 0 .. $#names ) { + my $pid = $pm->start($names[$child]) and next NAMES; + + # This code is the child process + print "This is $names[$child], Child number $child\n"; + sleep ( 2 * $child ); + print "$names[$child], Child $child is about to get out...\n"; + sleep 1; + $pm->finish($child); # pass an exit code to finish + } + + print "Waiting for Children...\n"; + $pm->wait_all_children; + print "Everybody is out of the pool!\n"; + +## Data structure retrieval + +In this simple example, each child sends back a string reference. + + use Parallel::ForkManager 0.7.6; + use strict; + + my $pm = Parallel::ForkManager->new(2, '/server/path/to/temp/dir/'); + + # data structure retrieval and handling + $pm -> run_on_finish ( # called BEFORE the first call to start() + sub { + my ($pid, $exit_code, $ident, $exit_signal, $core_dump, $data_structure_reference) = @_; + + # retrieve data structure from child + if (defined($data_structure_reference)) { # children are not forced to send anything + my $string = ${$data_structure_reference}; # child passed a string reference + print "$string\n"; + } + else { # problems occurring during storage or retrieval will throw a warning + print qq|No message received from child process $pid!\n|; + } + } + ); + + # prep random statement components + my @foods = ('chocolate', 'ice cream', 'peanut butter', 'pickles', 'pizza', 'bacon', 'pancakes', 'spaghetti', 'cookies'); + my @preferences = ('loves', q|can't stand|, 'always wants more', 'will walk 100 miles for', 'only eats', 'would starve rather than eat'); + + # run the parallel processes + PERSONS: + foreach my $person (qw(Fred Wilma Ernie Bert Lucy Ethel Curly Moe Larry)) { + $pm->start() and next PERSONS; + + # generate a random statement about food preferences + my $statement = $person . ' ' . $preferences[int(rand @preferences)] . ' ' . $foods[int(rand @foods)]; + + # send it back to the parent process + $pm->finish(0, \$statement); # note that it's a scalar REFERENCE, not the scalar itself + } + $pm->wait_all_children; + +A second datastructure retrieval example demonstrates how children decide +whether or not to send anything back, what to send and how the parent should +process whatever is retrieved. + + use Parallel::ForkManager 0.7.6; + use Data::Dumper; # to display the data structures retrieved. + use strict; + + my $pm = Parallel::ForkManager->new(20); # using the system temp dir $L run_on_finish ( + sub { + my ($pid, $exit_code, $ident, $exit_signal, $core_dump, $data_structure_reference) = @_; + + # see what the child sent us, if anything + if (defined($data_structure_reference)) { # test rather than assume child sent anything + my $reftype = ref($data_structure_reference); + print qq|ident "$ident" returned a "$reftype" reference.\n\n|; + if (1) { # simple on/off switch to display the contents + print &Dumper($data_structure_reference) . qq|end of "$ident" sent structure\n\n|; + } + + # we can also collect retrieved data structures for processing after all children have exited + $retrieved_responses{$ident} = $data_structure_reference; + } else { + print qq|ident "$ident" did not send anything.\n\n|; + } + } + ); + + # generate a list of instructions + my @instructions = ( # a unique identifier and what the child process should send + {'name' => '%ENV keys as a string', 'send' => 'keys'}, + {'name' => 'Send Nothing'}, # not instructing the child to send anything back to the parent + {'name' => 'Childs %ENV', 'send' => 'all'}, + {'name' => 'Child chooses randomly', 'send' => 'random'}, + {'name' => 'Invalid send instructions', 'send' => 'Na Na Nana Na'}, + {'name' => 'ENV values in an array', 'send' => 'values'}, + ); + + INSTRUCTS: + foreach my $instruction (@instructions) { + $pm->start($instruction->{'name'}) and next INSTRUCTS; # this time we are using an explicit, unique child process identifier + + # last step in child processing + $pm->finish(0) unless $instruction->{'send'}; # no data structure is sent unless this child is told what to send. + + if ($instruction->{'send'} eq 'keys') { + $pm->finish(0, \join(', ', keys %ENV)); + + } elsif ($instruction->{'send'} eq 'values') { + $pm->finish(0, [values %ENV]); # kinda useless without knowing which keys they belong to... + + } elsif ($instruction->{'send'} eq 'all') { + $pm->finish(0, \%ENV); # remember, we are not "returning" anything, just copying the hash to disc + + # demonstrate clearly that the child determines what type of reference to send + } elsif ($instruction->{'send'} eq 'random') { + my $string = q|I'm just a string.|; + my @array = qw(I am an array); + my %hash = (type => 'associative array', synonym => 'hash', cool => 'very :)'); + my $return_choice = ('string', 'array', 'hash')[int(rand 3)]; # randomly choose return data type + $pm->finish(0, \$string) if ($return_choice eq 'string'); + $pm->finish(0, \@array) if ($return_choice eq 'array'); + $pm->finish(0, \%hash) if ($return_choice eq 'hash'); + + # as a responsible child, inform parent that their instruction was invalid + } else { + $pm->finish(0, \qq|Invalid instructions: "$instruction->{'send'}".|); # ordinarily I wouldn't include invalid input in a response... + } + } + $pm->wait_all_children; # blocks until all forked processes have exited + + # post fork processing of returned data structures + for (sort keys %retrieved_responses) { + print qq|Post processing "$_"...\n|; + } + +# SECURITY + +Parallel::ForkManager uses temporary files when +a child process returns information to its parent process. The filenames are +based on the process of the parent and child processes, so they are +fairly easy to guess. So if security is a concern in your environment, make sure +the directory used by Parallel::ForkManager is restricted to the current user +only (the default behavior is to create a directory, +via [File::Temp](https://metacpan.org/pod/File::Temp)'s `tempdir`, which does that). + +# TROUBLESHOOTING + +## PerlIO::gzip and Parallel::ForkManager do not play nice together + +If you are using [PerlIO::gzip](https://metacpan.org/pod/PerlIO::gzip) in your child processes, you may end up with +garbled files. This is not really P::FM's fault, but rather a problem between +[PerlIO::gzip](https://metacpan.org/pod/PerlIO::gzip) and `fork()` (see [https://rt.cpan.org/Public/Bug/Display.html?id=114557](https://rt.cpan.org/Public/Bug/Display.html?id=114557)). + +Fortunately, it seems there is an easy way to fix the problem by +adding the "unix" layer? I.e., + + open(IN, '<:unix:gzip', ... + +# BUGS AND LIMITATIONS + +Do not use Parallel::ForkManager in an environment, where other child +processes can affect the run of the main program, so using this module +is not recommended in an environment where fork() / wait() is already used. + +If you want to use more than one copies of the Parallel::ForkManager, then +you have to make sure that all children processes are terminated, before you +use the second object in the main program. + +You are free to use a new copy of Parallel::ForkManager in the child +processes, although I don't think it makes sense. + +# CREDITS + + Michael Gang (bug report) + Noah Robin (documentation tweaks) + Chuck Hirstius (callback exit status, example) + Grant Hopwood (win32 port) + Mark Southern (bugfix) + Ken Clarke (datastructure retrieval) + +# AUTHORS + +- dLux (Szabó, Balázs) +- Yanick Champoux [![endorse](http://api.coderwall.com/yanick/endorsecount.png)](http://coderwall.com/yanick) +- Gabor Szabo + +# COPYRIGHT AND LICENSE + +This software is copyright (c) 2000 by Balázs Szabó. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. diff --git a/SIGNATURE b/SIGNATURE new file mode 100644 index 0000000..978ab73 --- /dev/null +++ b/SIGNATURE @@ -0,0 +1,54 @@ +This file contains message digests of all files listed in MANIFEST, +signed via the Module::Signature module, version 0.79. + +To verify the content in this distribution, first make sure you have +Module::Signature installed, then type: + + % cpansign -v + +It will check each file's integrity, as well as the signature's +validity. If "==> Signature verified OK! <==" is not displayed, +the distribution may already have been compromised, and you should +not run its Makefile.PL or Build.PL. + +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA1 + +SHA1 fd95b68f03486ef0bc44ad34a47a130c661ed30e CONTRIBUTORS +SHA1 1fb9b44941cd74036c466ec3a05229a84a6acda0 Changes +SHA1 1fdb4343640b1dc9bf826eda0dd096ecbf52930d INSTALL +SHA1 9dada6b6e91e293b8a7eec08f51e3b28af9d8b8f MANIFEST +SHA1 f2e3caf3e6a69a99238d4d4264d203a45b883da0 META.json +SHA1 55855abf212a7dafc16a2c7d91562a4274e451a9 META.yml +SHA1 52760fb8f03cb7dba7a3f336d746e84709a3aa0b Makefile.PL +SHA1 3016da42d4c55c751265d7e4272436b3c8212e46 README.mkdn +SHA1 15c889dc5dae788fc02fb6a7cc28cb9c49e4d82e cpanfile +SHA1 4d6679ceacdf96ba45b5e0e32d3f22f9a73770a0 doap.xml +SHA1 0bc4eff0fe3043f9fe2feb21b028780856e87203 examples/callback.pl +SHA1 1b7dab748d481089c80d416d93b96115dc4486d4 examples/callback_data.pl +SHA1 e14c174c581239b856e5b5c279716951a70f6eca examples/parallel_get.pl +SHA1 a010a71ce9cf3396a78247acd9144fcfc28bb7cf lib/Parallel/ForkManager.pm +SHA1 562bfacd340b01259604e05492ef7f527d480958 t/00-compile.t +SHA1 4439fa08acd3f8cfe4658640218be5fc4ed6c260 t/00-load.t +SHA1 98b37452dda153ac3d85a6ae676ef248755d35ec t/00-report-prereqs.dd +SHA1 504a672015f8761f5bad3863d844954c9e803c3f t/00-report-prereqs.t +SHA1 4db3efffcfef330a6451166d6c7993f92bbba218 t/01-utf8-all.t +SHA1 7ff8a7ee4a5960791a23a739a43b1628279548ef t/02-callback.t +SHA1 ff8a6cea67626e7da6bf58c29c9b994d3991e4c9 t/03-callback-data.t +SHA1 19208bbd9b74cd32cbc76dcbaf67c8ca4c17e866 t/basic-methods.t +SHA1 6dce2e71e2969e784eb9a390a63b95ea05baef54 t/callback.txt +SHA1 cef973989a30e506d69e7ab93ad174fcd10a1d99 t/callback_data.txt +SHA1 fabacecff55314ac9fddec9a583345bebe09663f t/changing-pids.t +SHA1 e9904ab9b4005de2fcb193ace4657acd1c42f1b0 t/start_child.t +SHA1 e5f4aae96fc318e949d2367743e5d2ee12063246 t/waitpid-conflict.t +SHA1 a91aaaf17a7a2878a8b031d2f686dc4bebefd2e1 t/waitpid-waitonechild.t +SHA1 2fb16c9b79833c349b8429bcb047ffcbf64772a6 t/waitpid_blocking.t +SHA1 80ab1faf5d8174920b60461bf8c11e2225861f42 xt/release/pause-permissions.t +SHA1 d1fe7d94b3edc7847eb187d4ee41f66e19cf8907 xt/release/unused-vars.t +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1 + +iEYEARECAAYFAldzAe4ACgkQ34Hwf+GwC4y23wCgnxUtO6xVSRJbQgcBtkPr2t9k +t4gAoJXtjUYebtyxZ+b4CEQCXFwvO//p +=oOi+ +-----END PGP SIGNATURE----- diff --git a/cpanfile b/cpanfile new file mode 100644 index 0000000..728c435 --- /dev/null +++ b/cpanfile @@ -0,0 +1,33 @@ +requires "Carp" => "0"; +requires "File::Path" => "0"; +requires "File::Spec" => "0"; +requires "File::Temp" => "0"; +requires "POSIX" => "0"; +requires "Storable" => "0"; +requires "strict" => "0"; + +on 'test' => sub { + requires "ExtUtils::MakeMaker" => "0"; + requires "File::Spec" => "0"; + requires "IO::Handle" => "0"; + requires "IPC::Open3" => "0"; + requires "Test::More" => "0.94"; + requires "Test::Warn" => "0"; + requires "perl" => "5.006"; + requires "warnings" => "0"; +}; + +on 'test' => sub { + recommends "CPAN::Meta" => "2.120900"; +}; + +on 'configure' => sub { + requires "ExtUtils::MakeMaker" => "0"; +}; + +on 'develop' => sub { + requires "Test::More" => "0.96"; + requires "Test::PAUSE::Permissions" => "0"; + requires "Test::Vars" => "0"; + requires "warnings" => "0"; +}; diff --git a/doap.xml b/doap.xml new file mode 100644 index 0000000..c11857c --- /dev/null +++ b/doap.xml @@ -0,0 +1,243 @@ + + + Parallel-ForkManager + A simple parallel processing fork manager + + + dLux (Szabó, Balázs) + + + + + + Yanick Champoux + + + + + + Gabor Szabo + + + + + + Ninebit + + + + + + Shlomi Fish + + + + + + + + + + + + + + + 0.7.1 + 2001-04-26 + + + + + 0.7.2 + 2001-05-14 + + + + + 0.7.3 + 2001-08-24 + + + + + 0.7.4 + 2002-07-04 + + + + + 0.7.5 + 2002-12-25 + + + + + 0.7.6 + 2010-08-15 + + + + + 0.7.7 + 2010-09-28 + + + + + 0.7.8 + 2010-08-25 + + + + + 0.7.9 + 2010-11-01 + + + + + 0.5 + 2000-10-18 + + + + + 0.6 + 2000-11-30 + + + + + 0.7 + 2001-04-04 + + + + + 1.0.0 + 2012-12-23 + + + + + 1.01 + 2012-12-23 + + + + + 1.02 + 2012-12-24 + + + + + 1.03 + 2013-03-06 + + + + + 1.04 + 2013-09-03 + + + + + 1.05 + 2013-09-18 + + + + + 1.06 + 2013-12-24 + + + + + 1.07 + 2014-11-10 + + + + + 1.08 + 2015-01-07 + + + + + 1.09 + 2015-01-08 + + + + + 1.10_1 + 2015-01-22 + + + + + 1.10_2 + 2015-01-25 + + + + + 1.11 + 2015-01-30 + + + + + 1.12 + 2015-02-23 + + + + + 1.13 + 2015-05-11 + + + + + 1.14 + 2015-05-17 + + + + + 1.15 + 2015-07-08 + + + + + 1.16 + 2015-10-08 + + + + + 1.17 + 2015-11-28 + + + + + 1.18 + 2016-03-29 + + + Perl + diff --git a/examples/callback.pl b/examples/callback.pl new file mode 100755 index 0000000..649ecf6 --- /dev/null +++ b/examples/callback.pl @@ -0,0 +1,48 @@ +#!/usr/bin/perl -w +use lib '.'; +use strict; +use Parallel::ForkManager; + +my $max_procs = 3; +my @names = qw( Fred Jim Lily Steve Jessica Bob ); +# hash to resolve PID's back to child specific information + +my $pm = Parallel::ForkManager->new($max_procs); + +# Setup a callback for when a child finishes up so we can +# get it's exit code +$pm->run_on_finish( + sub { my ($pid, $exit_code, $ident) = @_; + print "** $ident just got out of the pool ". + "with PID $pid and exit code: $exit_code\n"; + } +); + +$pm->run_on_start( + sub { my ($pid,$ident)=@_; + print "** $ident started, pid: $pid\n"; + } +); + +$pm->run_on_wait( + sub { + print "** Have to wait for one children ...\n" + }, + 0.5, +); + +foreach my $child ( 0 .. $#names ) { + my $pid = $pm->start($names[$child]) and next; + + # This code is the child process + print "This is $names[$child], Child number $child\n"; + sleep ( 2 * $child ); + print "$names[$child], Child $child is about to get out...\n"; + sleep 1; + $pm->finish($child); # pass an exit code to finish +} + +print "Waiting for Children...\n"; +$pm->wait_all_children; +print "Everybody is out of the pool!\n"; + diff --git a/examples/callback_data.pl b/examples/callback_data.pl new file mode 100644 index 0000000..97c6cfc --- /dev/null +++ b/examples/callback_data.pl @@ -0,0 +1,42 @@ +#!/usr/bin/perl +use strict; +use warnings; + +use Parallel::ForkManager; + +my $max_procs = 2; +my @names = qw( Fred Jim ); + +my $pm = Parallel::ForkManager->new($max_procs, @ARGV); + +# Setup a callback for when a child finishes up so we can +# get it's exit code and any data it collected +$pm->run_on_finish( sub { + my ($pid, $exit_code, $ident, $exit_signal, $core_dump, $data_structure_reference) = @_; + print "$ident just got out of the pool ". + "with exit code: $exit_code and data: @$data_structure_reference\n"; +}); + +$pm->run_on_start( sub { + my ($pid,$ident)=@_; + print "$ident started\n"; +}); + +foreach my $child ( 0 .. $#names ) { + my $pid = $pm->start($names[$child]) and next; + + # This code is the child process + # We can do here anything and obtain any data. + # The result can be any array or hash. + my @result = ($names[$child], length $names[$child]); + sleep 1+rand(3); + + # pass an exit code and data stucture to finish + $pm->finish($child, \@result ); +} + +#print "Waiting for Children...\n"; +$pm->wait_all_children; +print "Everybody is out of the pool!\n"; + + diff --git a/examples/parallel_get.pl b/examples/parallel_get.pl new file mode 100755 index 0000000..2a88458 --- /dev/null +++ b/examples/parallel_get.pl @@ -0,0 +1,32 @@ +#!/usr/bin/perl +use strict; +use warnings; + +if (not @ARGV) { + die <<"DIE"; +Usage: $0 URL URL... + e.g.: $0 http://cpan.metacpan.org/authors/id/D/DL/DLUX/Parallel-ForkManager-0.7.9.tar.gz +DIE +} + +use Parallel::ForkManager; +use LWP::Simple; + +my $pm = Parallel::ForkManager->new(10); + +for my $link (@ARGV) { + $pm->start and next; + + my ($fn) = $link =~ /^.*\/(.*?)$/; + + if (!$fn) { + warn "Cannot determine filename from $fn\n"; + } else { + $0 .= " $fn"; + print "Getting $fn from $link\n"; + my $rc = getstore($link, $fn); + print "$link downloaded. response code: $rc\n"; + }; + + $pm->finish; +}; diff --git a/lib/Parallel/ForkManager.pm b/lib/Parallel/ForkManager.pm new file mode 100644 index 0000000..6eaa321 --- /dev/null +++ b/lib/Parallel/ForkManager.pm @@ -0,0 +1,891 @@ +package Parallel::ForkManager; +our $AUTHORITY = 'cpan:DLUX'; +# ABSTRACT: A simple parallel processing fork manager +$Parallel::ForkManager::VERSION = '1.19'; +use POSIX ":sys_wait_h"; +use Storable qw(store retrieve); +use File::Spec; +use File::Temp (); +use File::Path (); +use Carp; + +use strict; + +sub new { + my ($c,$processes,$tempdir)=@_; + + my $h={ + max_proc => $processes, + processes => {}, + in_child => 0, + parent_pid => $$, + auto_cleanup => ($tempdir ? 0 : 1), + waitpid_blocking_sleep => 1, + }; + + + # determine temporary directory for storing data structures + # add it to Parallel::ForkManager object so children can use it + # We don't let it clean up so it won't do it in the child process + # but we have our own DESTROY to do that. + if (not defined($tempdir) or not length($tempdir)) { + $tempdir = File::Temp::tempdir(CLEANUP => 0); + } + die qq|Temporary directory "$tempdir" doesn't exist or is not a directory.| unless (-e $tempdir && -d _); # ensure temp dir exists and is indeed a directory + $h->{tempdir} = $tempdir; + + return bless($h,ref($c)||$c); +}; + +sub start { + my ($s,$identification)=@_; + + die "Cannot start another process while you are in the child process" + if $s->{in_child}; + while ($s->{max_proc} && ( keys %{ $s->{processes} } ) >= $s->{max_proc}) { + $s->on_wait; + $s->wait_one_child(defined $s->{on_wait_period} ? &WNOHANG : undef); + }; + $s->wait_children; + if ($s->{max_proc}) { + my $pid=fork(); + die "Cannot fork: $!" if !defined $pid; + if ($pid) { + $s->{processes}->{$pid}=$identification; + $s->on_start($pid,$identification); + } else { + $s->{in_child}=1 if !$pid; + } + return $pid; + } else { + $s->{processes}->{$$}=$identification; + $s->on_start($$,$identification); + return 0; # Simulating the child which returns 0 + } +} + +sub start_child { + my $self = shift; + my $sub = pop; + my $identification = shift; + + $self->start( $identification ) # in the parent + # ... or the child + or $self->finish( 0, $sub->() ); +} + + +sub finish { + my ($s, $x, $r)=@_; + + if ( $s->{in_child} ) { + if (defined($r)) { # store the child's data structure + my $storable_tempfile = File::Spec->catfile($s->{tempdir}, 'Parallel-ForkManager-' . $s->{parent_pid} . '-' . $$ . '.txt'); + my $stored = eval { return &store($r, $storable_tempfile); }; + + # handle Storables errors, IE logcarp or carp returning undef, or die (via logcroak or croak) + if (not $stored or $@) { + warn(qq|The storable module was unable to store the child's data structure to the temp file "$storable_tempfile": | . join(', ', $@)); + } + } + CORE::exit($x || 0); + } + if ($s->{max_proc} == 0) { # max_proc == 0 + $s->on_finish($$, $x ,$s->{processes}->{$$}, 0, 0, $r); + delete $s->{processes}->{$$}; + } + return 0; +} + +sub wait_children { + my ($s)=@_; + + return if !keys %{$s->{processes}}; + my $kid; + do { + $kid = $s->wait_one_child(&WNOHANG); + } while defined $kid and ( $kid > 0 or $kid < -1 ); # AS 5.6/Win32 returns negative PIDs +}; + +*wait_childs=*wait_children; # compatibility +*reap_finished_children=*wait_children; # behavioral synonym for clarity + +sub wait_one_child { + my ($s,$par)=@_; + + my $kid; + while (1) { + $kid = $s->_waitpid(-1,$par||=0); + + last unless defined $kid; + + last if $kid == 0 || $kid == -1; # AS 5.6/Win32 returns negative PIDs + redo if !exists $s->{processes}->{$kid}; + my $id = delete $s->{processes}->{$kid}; + + # retrieve child data structure, if any + my $retrieved = undef; + my $storable_tempfile = File::Spec->catfile($s->{tempdir}, 'Parallel-ForkManager-' . $s->{parent_pid} . '-' . $kid . '.txt'); + if (-e $storable_tempfile) { # child has option of not storing anything, so we need to see if it did or not + $retrieved = eval { return &retrieve($storable_tempfile); }; + + # handle Storables errors + if (not $retrieved or $@) { + warn(qq|The storable module was unable to retrieve the child's data structure from the temporary file "$storable_tempfile": | . join(', ', $@)); + } + + # clean up after ourselves + unlink $storable_tempfile; + } + + $s->on_finish( $kid, $? >> 8 , $id, $? & 0x7f, $? & 0x80 ? 1 : 0, $retrieved); + last; + } + $kid; +}; + +sub wait_all_children { + my ($s)=@_; + + while (keys %{ $s->{processes} }) { + $s->on_wait; + $s->wait_one_child(defined $s->{on_wait_period} ? &WNOHANG : undef); + }; +} + +*wait_all_childs=*wait_all_children; # compatibility; + +sub max_procs { $_[0]->{max_proc}; } + +sub is_child { $_[0]->{in_child} } + +sub is_parent { !$_[0]->{in_child} } + +sub running_procs { + my $self = shift; + + my @pids = keys %{ $self->{processes} }; + return @pids; +} + +sub wait_for_available_procs { + my( $self, $nbr ) = @_; + $nbr ||= 1; + + croak "nbr processes '$nbr' higher than the max nbr of processes (@{[ $self->max_procs ]})" + if $nbr > $self->max_procs; + + $self->wait_one_child until $self->max_procs - $self->running_procs >= $nbr; +} + +sub run_on_finish { + my ($s,$code,$pid)=@_; + + $s->{on_finish}->{$pid || 0}=$code; +} + +sub on_finish { + my ($s,$pid,@par)=@_; + + my $code=$s->{on_finish}->{$pid} || $s->{on_finish}->{0} or return 0; + $code->($pid,@par); +}; + +sub run_on_wait { + my ($s,$code, $period)=@_; + + $s->{on_wait}=$code; + $s->{on_wait_period} = $period; +} + +sub on_wait { + my ($s)=@_; + + if(ref($s->{on_wait}) eq 'CODE') { + $s->{on_wait}->(); + if (defined $s->{on_wait_period}) { + local $SIG{CHLD} = sub { } if ! defined $SIG{CHLD}; + select undef, undef, undef, $s->{on_wait_period} + }; + }; +}; + +sub run_on_start { + my ($s,$code)=@_; + + $s->{on_start}=$code; +} + +sub on_start { + my ($s,@par)=@_; + + $s->{on_start}->(@par) if ref($s->{on_start}) eq 'CODE'; +}; + +sub set_max_procs { + my ($s, $mp)=@_; + + $s->{max_proc} = $mp; +} + +sub set_waitpid_blocking_sleep { + my( $self, $period ) = @_; + $self->{waitpid_blocking_sleep} = $period; +} + +sub waitpid_blocking_sleep { + $_[0]->{waitpid_blocking_sleep}; +} + +sub _waitpid { # Call waitpid() in the standard Unix fashion. + my( $self, undef, $flag ) = @_; + + return $flag ? $self->_waitpid_non_blocking : $self->_waitpid_blocking; +} + +sub _waitpid_non_blocking { + my $self = shift; + + for my $pid ( $self->running_procs ) { + my $p = waitpid $pid, &WNOHANG or next; + + return $pid if $p != -1; + + warn "child process '$pid' disappeared. A call to `waitpid` outside of Parallel::ForkManager might have reaped it.\n"; + # it's gone. let's clean the process entry + delete $self->{processes}{$pid}; + } + + return; +} + +sub _waitpid_blocking { + my $self = shift; + + # pseudo-blocking + if( my $sleep_period = $self->{waitpid_blocking_sleep} ) { + while() { + my $pid = $self->_waitpid_non_blocking; + + return $pid if defined $pid; + + return unless $self->running_procs; + + select undef, undef, undef, $sleep_period; + } + } + + return waitpid -1, 0; +} + +sub DESTROY { + my ($self) = @_; + + if ($self->{auto_cleanup} && $self->{parent_pid} == $$ && -d $self->{tempdir}) { + File::Path::remove_tree($self->{tempdir}); + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Parallel::ForkManager - A simple parallel processing fork manager + +=head1 VERSION + +version 1.19 + +=head1 SYNOPSIS + + use Parallel::ForkManager; + + my $pm = Parallel::ForkManager->new($MAX_PROCESSES); + + DATA_LOOP: + foreach my $data (@all_data) { + # Forks and returns the pid for the child: + my $pid = $pm->start and next DATA_LOOP; + + ... do some work with $data in the child process ... + + $pm->finish; # Terminates the child process + } + +=head1 DESCRIPTION + +This module is intended for use in operations that can be done in parallel +where the number of processes to be forked off should be limited. Typical +use is a downloader which will be retrieving hundreds/thousands of files. + +The code for a downloader would look something like this: + + use LWP::Simple; + use Parallel::ForkManager; + + ... + + my @links=( + ["http://www.foo.bar/rulez.data","rulez_data.txt"], + ["http://new.host/more_data.doc","more_data.doc"], + ... + ); + + ... + + # Max 30 processes for parallel download + my $pm = Parallel::ForkManager->new(30); + + LINKS: + foreach my $linkarray (@links) { + $pm->start and next LINKS; # do the fork + + my ($link, $fn) = @$linkarray; + warn "Cannot get $fn from $link" + if getstore($link, $fn) != RC_OK; + + $pm->finish; # do the exit in the child process + } + $pm->wait_all_children; + +First you need to instantiate the ForkManager with the "new" constructor. +You must specify the maximum number of processes to be created. If you +specify 0, then NO fork will be done; this is good for debugging purposes. + +Next, use $pm->start to do the fork. $pm returns 0 for the child process, +and child pid for the parent process (see also L). +The "and next" skips the internal loop in the parent process. NOTE: +$pm->start dies if the fork fails. + +$pm->finish terminates the child process (assuming a fork was done in the +"start"). + +NOTE: You cannot use $pm->start if you are already in the child process. +If you want to manage another set of subprocesses in the child process, +you must instantiate another Parallel::ForkManager object! + +=head1 METHODS + +The comment letter indicates where the method should be run. P for parent, +C for child. + +=over 5 + +=item new $processes + +Instantiate a new Parallel::ForkManager object. You must specify the maximum +number of children to fork off. If you specify 0 (zero), then no children +will be forked. This is intended for debugging purposes. + +The optional second parameter, $tempdir, is only used if you want the +children to send back a reference to some data (see RETRIEVING DATASTRUCTURES +below). If not provided, it is set via a call to L::tempdir(). + +The new method will die if the temporary directory does not exist or it is not +a directory. + +=item start [ $process_identifier ] + +This method does the fork. It returns the pid of the child process for +the parent, and 0 for the child process. If the $processes parameter +for the constructor is 0 then, assuming you're in the child process, +$pm->start simply returns 0. + +An optional $process_identifier can be provided to this method... It is used by +the "run_on_finish" callback (see CALLBACKS) for identifying the finished +process. + +=item start_child [ $process_identifier, ] \&callback + +Like C, but will run the C<&callback> as the child. If the callback returns anything, +it'll be passed as the data to transmit back to the parent process via C. + +=item finish [ $exit_code [, $data_structure_reference] ] + +Closes the child process by exiting and accepts an optional exit code +(default exit code is 0) which can be retrieved in the parent via callback. +If the second optional parameter is provided, the child attempts to send +its contents back to the parent. If you use the program in debug mode +($processes == 0), this method just calls the callback. + +If the $data_structure_reference is provided, then it is serialized and +passed to the parent process. See RETRIEVING DATASTRUCTURES for more info. + +=item set_max_procs $processes + +Allows you to set a new maximum number of children to maintain. + +=item wait_all_children + +You can call this method to wait for all the processes which have been +forked. This is a blocking wait. + +=item reap_finished_children + +This is a non-blocking call to reap children and execute callbacks independent +of calls to "start" or "wait_all_children". Use this in scenarios where "start" +is called infrequently but you would like the callbacks executed quickly. + +=item is_parent + +Returns C if within the parent or C if within the child. + +=item is_child + +Returns C if within the child or C if within the parent. + +=item max_procs + +Returns the maximal number of processes the object will fork. + +=item running_procs + +Returns the pids of the forked processes currently monitored by the +C. Note that children are still reported as running +until the fork manager harvest them, via the next call to +C or C. + + my @pids = $pm->running_procs; + + my $nbr_children =- $pm->running_procs; + +=item wait_for_available_procs( $n ) + +Wait until C<$n> available process slots are available. +If C<$n> is not given, defaults to I<1>. + +=item waitpid_blocking_sleep + +Returns the sleep period, in seconds, of the pseudo-blocking calls. The sleep +period can be a fraction of second. + +Returns C<0> if disabled. + +Defaults to 1 second. + +See I for more details. + +=item set_waitpid_blocking_sleep $seconds + +Sets the the sleep period, in seconds, of the pseudo-blocking calls. +Set to C<0> to disable. + +See I for more details. + +=back + +=head1 CALLBACKS + +You can define callbacks in the code, which are called on events like starting +a process or upon finish. Declare these before the first call to start(). + +The callbacks can be defined with the following methods: + +=over 4 + +=item run_on_finish $code [, $pid ] + +You can define a subroutine which is called when a child is terminated. It is +called in the parent process. + +The parameters of the $code are the following: + + - pid of the process, which is terminated + - exit code of the program + - identification of the process (if provided in the "start" method) + - exit signal (0-127: signal name) + - core dump (1 if there was core dump at exit) + - datastructure reference or undef (see RETRIEVING DATASTRUCTURES) + +=item run_on_start $code + +You can define a subroutine which is called when a child is started. It called +after the successful startup of a child in the parent process. + +The parameters of the $code are the following: + + - pid of the process which has been started + - identification of the process (if provided in the "start" method) + +=item run_on_wait $code, [$period] + +You can define a subroutine which is called when the child process needs to wait +for the startup. If $period is not defined, then one call is done per +child. If $period is defined, then $code is called periodically and the +module waits for $period seconds between the two calls. Note, $period can be +fractional number also. The exact "$period seconds" is not guaranteed, +signals can shorten and the process scheduler can make it longer (on busy +systems). + +The $code called in the "start" and the "wait_all_children" method also. + +No parameters are passed to the $code on the call. + +=back + +=head1 BLOCKING CALLS + +When it comes to waiting for child processes to terminate, C is between +a fork and a hard place (if you excuse the terrible pun). The underlying Perl C function +that the module relies on can block until either one specific or any child process +terminate, but not for a process part of a given group. + +This means that the module can do one of two things when it waits for +one of its child processes to terminate: + +=over + +=item Only wait for its own child processes + +This is done via a loop using a C non-blocking call and a sleep statement. +The code does something along the lines of + + while(1) { + if ( any of the P::FM child process terminated ) { + return its pid + } + + sleep $sleep_period + } + +This is the default behavior that the module will use. +This is not the most efficient way to wait for child processes, but it's +the safest way to ensure that C won't interfere with +any other part of the codebase. + +The sleep period is set via the method C. + +=item Block until any process terminate + +Alternatively, C can call C such that it will +block until any child process terminate. If the child process was not one of +the monitored subprocesses, the wait will resume. This is more efficient, but mean +that C can captures (and discards) the termination notification that a different +part of the code might be waiting for. + +If this is a race condition +that doesn't apply to your codebase, you can set the +I period to C<0>, which will enable C call blocking. + + my $pm = Parallel::ForkManager->new( 4 ); + + $pm->set_waitpid_blocking_sleep(0); # true blocking calls enabled + + for ( 1..100 ) { + $pm->start and next; + + ...; # do work + + $pm->finish; + } + +=back + +=head1 RETRIEVING DATASTRUCTURES from child processes + +The ability for the parent to retrieve data structures is new as of version +0.7.6. + +Each child process may optionally send 1 data structure back to the parent. +By data structure, we mean a reference to a string, hash or array. The +contents of the data structure are written out to temporary files on disc +using the L modules' store() method. The reference is then +retrieved from within the code you send to the run_on_finish callback. + +The data structure can be any scalar perl data structure which makes sense: +string, numeric value or a reference to an array, hash or object. + +There are 2 steps involved in retrieving data structures: + +1) A reference to the data structure the child wishes to send back to the +parent is provided as the second argument to the finish() call. It is up +to the child to decide whether or not to send anything back to the parent. + +2) The data structure reference is retrieved using the callback provided in +the run_on_finish() method. + +Keep in mind that data structure retrieval is not the same as returning a +data structure from a method call. That is not what actually occurs. The +data structure referenced in a given child process is serialized and +written out to a file by L. The file is subsequently read back +into memory and a new data structure belonging to the parent process is +created. Please consider the performance penalty it can imply, so try to +keep the returned structure small. + +=head1 EXAMPLES + +=head2 Parallel get + +This small example can be used to get URLs in parallel. + + use Parallel::ForkManager; + use LWP::Simple; + + my $pm = Parallel::ForkManager->new(10); + + LINKS: + for my $link (@ARGV) { + $pm->start and next LINKS; + my ($fn) = $link =~ /^.*\/(.*?)$/; + if (!$fn) { + warn "Cannot determine filename from $fn\n"; + } else { + $0 .= " " . $fn; + print "Getting $fn from $link\n"; + my $rc = getstore($link, $fn); + print "$link downloaded. response code: $rc\n"; + }; + $pm->finish; + }; + +=head2 Callbacks + +Example of a program using callbacks to get child exit codes: + + use strict; + use Parallel::ForkManager; + + my $max_procs = 5; + my @names = qw( Fred Jim Lily Steve Jessica Bob Dave Christine Rico Sara ); + # hash to resolve PID's back to child specific information + + my $pm = Parallel::ForkManager->new($max_procs); + + # Setup a callback for when a child finishes up so we can + # get it's exit code + $pm->run_on_finish( sub { + my ($pid, $exit_code, $ident) = @_; + print "** $ident just got out of the pool ". + "with PID $pid and exit code: $exit_code\n"; + }); + + $pm->run_on_start( sub { + my ($pid, $ident)=@_; + print "** $ident started, pid: $pid\n"; + }); + + $pm->run_on_wait( sub { + print "** Have to wait for one children ...\n" + }, + 0.5 + ); + + NAMES: + foreach my $child ( 0 .. $#names ) { + my $pid = $pm->start($names[$child]) and next NAMES; + + # This code is the child process + print "This is $names[$child], Child number $child\n"; + sleep ( 2 * $child ); + print "$names[$child], Child $child is about to get out...\n"; + sleep 1; + $pm->finish($child); # pass an exit code to finish + } + + print "Waiting for Children...\n"; + $pm->wait_all_children; + print "Everybody is out of the pool!\n"; + +=head2 Data structure retrieval + +In this simple example, each child sends back a string reference. + + use Parallel::ForkManager 0.7.6; + use strict; + + my $pm = Parallel::ForkManager->new(2, '/server/path/to/temp/dir/'); + + # data structure retrieval and handling + $pm -> run_on_finish ( # called BEFORE the first call to start() + sub { + my ($pid, $exit_code, $ident, $exit_signal, $core_dump, $data_structure_reference) = @_; + + # retrieve data structure from child + if (defined($data_structure_reference)) { # children are not forced to send anything + my $string = ${$data_structure_reference}; # child passed a string reference + print "$string\n"; + } + else { # problems occurring during storage or retrieval will throw a warning + print qq|No message received from child process $pid!\n|; + } + } + ); + + # prep random statement components + my @foods = ('chocolate', 'ice cream', 'peanut butter', 'pickles', 'pizza', 'bacon', 'pancakes', 'spaghetti', 'cookies'); + my @preferences = ('loves', q|can't stand|, 'always wants more', 'will walk 100 miles for', 'only eats', 'would starve rather than eat'); + + # run the parallel processes + PERSONS: + foreach my $person (qw(Fred Wilma Ernie Bert Lucy Ethel Curly Moe Larry)) { + $pm->start() and next PERSONS; + + # generate a random statement about food preferences + my $statement = $person . ' ' . $preferences[int(rand @preferences)] . ' ' . $foods[int(rand @foods)]; + + # send it back to the parent process + $pm->finish(0, \$statement); # note that it's a scalar REFERENCE, not the scalar itself + } + $pm->wait_all_children; + +A second datastructure retrieval example demonstrates how children decide +whether or not to send anything back, what to send and how the parent should +process whatever is retrieved. + +=for example begin + + use Parallel::ForkManager 0.7.6; + use Data::Dumper; # to display the data structures retrieved. + use strict; + + my $pm = Parallel::ForkManager->new(20); # using the system temp dir $L run_on_finish ( + sub { + my ($pid, $exit_code, $ident, $exit_signal, $core_dump, $data_structure_reference) = @_; + + # see what the child sent us, if anything + if (defined($data_structure_reference)) { # test rather than assume child sent anything + my $reftype = ref($data_structure_reference); + print qq|ident "$ident" returned a "$reftype" reference.\n\n|; + if (1) { # simple on/off switch to display the contents + print &Dumper($data_structure_reference) . qq|end of "$ident" sent structure\n\n|; + } + + # we can also collect retrieved data structures for processing after all children have exited + $retrieved_responses{$ident} = $data_structure_reference; + } else { + print qq|ident "$ident" did not send anything.\n\n|; + } + } + ); + + # generate a list of instructions + my @instructions = ( # a unique identifier and what the child process should send + {'name' => '%ENV keys as a string', 'send' => 'keys'}, + {'name' => 'Send Nothing'}, # not instructing the child to send anything back to the parent + {'name' => 'Childs %ENV', 'send' => 'all'}, + {'name' => 'Child chooses randomly', 'send' => 'random'}, + {'name' => 'Invalid send instructions', 'send' => 'Na Na Nana Na'}, + {'name' => 'ENV values in an array', 'send' => 'values'}, + ); + + INSTRUCTS: + foreach my $instruction (@instructions) { + $pm->start($instruction->{'name'}) and next INSTRUCTS; # this time we are using an explicit, unique child process identifier + + # last step in child processing + $pm->finish(0) unless $instruction->{'send'}; # no data structure is sent unless this child is told what to send. + + if ($instruction->{'send'} eq 'keys') { + $pm->finish(0, \join(', ', keys %ENV)); + + } elsif ($instruction->{'send'} eq 'values') { + $pm->finish(0, [values %ENV]); # kinda useless without knowing which keys they belong to... + + } elsif ($instruction->{'send'} eq 'all') { + $pm->finish(0, \%ENV); # remember, we are not "returning" anything, just copying the hash to disc + + # demonstrate clearly that the child determines what type of reference to send + } elsif ($instruction->{'send'} eq 'random') { + my $string = q|I'm just a string.|; + my @array = qw(I am an array); + my %hash = (type => 'associative array', synonym => 'hash', cool => 'very :)'); + my $return_choice = ('string', 'array', 'hash')[int(rand 3)]; # randomly choose return data type + $pm->finish(0, \$string) if ($return_choice eq 'string'); + $pm->finish(0, \@array) if ($return_choice eq 'array'); + $pm->finish(0, \%hash) if ($return_choice eq 'hash'); + + # as a responsible child, inform parent that their instruction was invalid + } else { + $pm->finish(0, \qq|Invalid instructions: "$instruction->{'send'}".|); # ordinarily I wouldn't include invalid input in a response... + } + } + $pm->wait_all_children; # blocks until all forked processes have exited + + # post fork processing of returned data structures + for (sort keys %retrieved_responses) { + print qq|Post processing "$_"...\n|; + } + +=for example end + +=head1 SECURITY + +Parallel::ForkManager uses temporary files when +a child process returns information to its parent process. The filenames are +based on the process of the parent and child processes, so they are +fairly easy to guess. So if security is a concern in your environment, make sure +the directory used by Parallel::ForkManager is restricted to the current user +only (the default behavior is to create a directory, +via L's C, which does that). + +=head1 TROUBLESHOOTING + +=head2 PerlIO::gzip and Parallel::ForkManager do not play nice together + +If you are using L in your child processes, you may end up with +garbled files. This is not really P::FM's fault, but rather a problem between +L and C (see L). + +Fortunately, it seems there is an easy way to fix the problem by +adding the "unix" layer? I.e., + + open(IN, '<:unix:gzip', ... + +=head1 BUGS AND LIMITATIONS + +Do not use Parallel::ForkManager in an environment, where other child +processes can affect the run of the main program, so using this module +is not recommended in an environment where fork() / wait() is already used. + +If you want to use more than one copies of the Parallel::ForkManager, then +you have to make sure that all children processes are terminated, before you +use the second object in the main program. + +You are free to use a new copy of Parallel::ForkManager in the child +processes, although I don't think it makes sense. + +=head1 CREDITS + + Michael Gang (bug report) + Noah Robin (documentation tweaks) + Chuck Hirstius (callback exit status, example) + Grant Hopwood (win32 port) + Mark Southern (bugfix) + Ken Clarke (datastructure retrieval) + +=head1 AUTHORS + +=over 4 + +=item * + +dLux (Szabó, Balázs) + +=item * + +Yanick Champoux + +=item * + +Gabor Szabo + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2000 by Balázs Szabó. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/t/00-compile.t b/t/00-compile.t new file mode 100644 index 0000000..faac267 --- /dev/null +++ b/t/00-compile.t @@ -0,0 +1,51 @@ +use 5.006; +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::Compile 2.052 + +use Test::More; + +plan tests => 1 + ($ENV{AUTHOR_TESTING} ? 1 : 0); + +my @module_files = ( + 'Parallel/ForkManager.pm' +); + + + +# no fake home requested + +my $inc_switch = -d 'blib' ? '-Mblib' : '-Ilib'; + +use File::Spec; +use IPC::Open3; +use IO::Handle; + +open my $stdin, '<', File::Spec->devnull or die "can't open devnull: $!"; + +my @warnings; +for my $lib (@module_files) +{ + # see L + my $stderr = IO::Handle->new; + + my $pid = open3($stdin, '>&STDERR', $stderr, $^X, $inc_switch, '-e', "require q[$lib]"); + binmode $stderr, ':crlf' if $^O eq 'MSWin32'; + my @_warnings = <$stderr>; + waitpid($pid, 0); + is($?, 0, "$lib loaded ok"); + + if (@_warnings) + { + warn @_warnings; + push @warnings, @_warnings; + } +} + + + +is(scalar(@warnings), 0, 'no warnings found') + or diag 'got warnings: ', ( Test::More->can('explain') ? Test::More::explain(\@warnings) : join("\n", '', @warnings) ) if $ENV{AUTHOR_TESTING}; + + diff --git a/t/00-load.t b/t/00-load.t new file mode 100644 index 0000000..5d2983a --- /dev/null +++ b/t/00-load.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More tests => 4; +use Parallel::ForkManager; +use File::Temp qw(tempdir); + +my @numbers = (1 .. 20); + +for my $processes ( 1, 3 ) { + for my $pseudo_block ( 0, 1 ) { + my $chrono = time; + is_deeply count($processes,$pseudo_block) => \@numbers, + "procs: $processes, pseudo-block: $pseudo_block"; + $chrono = time - $chrono; + diag "time: $chrono seconds"; + }; +} + + +sub count { + my ($concurrency,$blocking_time) = @_; + + my $dir = tempdir(CLEANUP => 1); + + my $fork = Parallel::ForkManager->new( $concurrency ); + $fork->set_waitpid_blocking_sleep( $blocking_time ); + + foreach my $n (@numbers) { + my $pid = $fork->start and next; + open my $fh, '>', "$dir/$n" or die; + close $fh or die; + $fork->finish; + } + $fork->wait_all_children; + opendir my $dh, $dir or die; + my @results = grep { $_ !~ /\./ } readdir $dh; + closedir $dh or die; + return [sort {$a <=> $b} @results]; +} + diff --git a/t/00-report-prereqs.dd b/t/00-report-prereqs.dd new file mode 100644 index 0000000..abfe35e --- /dev/null +++ b/t/00-report-prereqs.dd @@ -0,0 +1,43 @@ +do { my $x = { + 'configure' => { + 'requires' => { + 'ExtUtils::MakeMaker' => '0' + } + }, + 'develop' => { + 'requires' => { + 'Test::More' => '0.96', + 'Test::PAUSE::Permissions' => '0', + 'Test::Vars' => '0', + 'warnings' => '0' + } + }, + 'runtime' => { + 'requires' => { + 'Carp' => '0', + 'File::Path' => '0', + 'File::Spec' => '0', + 'File::Temp' => '0', + 'POSIX' => '0', + 'Storable' => '0', + 'strict' => '0' + } + }, + 'test' => { + 'recommends' => { + 'CPAN::Meta' => '2.120900' + }, + 'requires' => { + 'ExtUtils::MakeMaker' => '0', + 'File::Spec' => '0', + 'IO::Handle' => '0', + 'IPC::Open3' => '0', + 'Test::More' => '0.94', + 'Test::Warn' => '0', + 'perl' => '5.006', + 'warnings' => '0' + } + } + }; + $x; + } \ No newline at end of file diff --git a/t/00-report-prereqs.t b/t/00-report-prereqs.t new file mode 100644 index 0000000..d8d15ba --- /dev/null +++ b/t/00-report-prereqs.t @@ -0,0 +1,183 @@ +#!perl + +use strict; +use warnings; + +# This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.021 + +use Test::More tests => 1; + +use ExtUtils::MakeMaker; +use File::Spec; + +# from $version::LAX +my $lax_version_re = + qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )? + | + (?:\.[0-9]+) (?:_[0-9]+)? + ) | (?: + v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )? + | + (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)? + ) + )/x; + +# hide optional CPAN::Meta modules from prereq scanner +# and check if they are available +my $cpan_meta = "CPAN::Meta"; +my $cpan_meta_pre = "CPAN::Meta::Prereqs"; +my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic + +# Verify requirements? +my $DO_VERIFY_PREREQS = 1; + +sub _max { + my $max = shift; + $max = ( $_ > $max ) ? $_ : $max for @_; + return $max; +} + +sub _merge_prereqs { + my ($collector, $prereqs) = @_; + + # CPAN::Meta::Prereqs object + if (ref $collector eq $cpan_meta_pre) { + return $collector->with_merged_prereqs( + CPAN::Meta::Prereqs->new( $prereqs ) + ); + } + + # Raw hashrefs + for my $phase ( keys %$prereqs ) { + for my $type ( keys %{ $prereqs->{$phase} } ) { + for my $module ( keys %{ $prereqs->{$phase}{$type} } ) { + $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module}; + } + } + } + + return $collector; +} + +my @include = qw( + +); + +my @exclude = qw( + +); + +# Add static prereqs to the included modules list +my $static_prereqs = do 't/00-report-prereqs.dd'; + +# Merge all prereqs (either with ::Prereqs or a hashref) +my $full_prereqs = _merge_prereqs( + ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ), + $static_prereqs +); + +# Add dynamic prereqs to the included modules list (if we can) +my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; +if ( $source && $HAS_CPAN_META ) { + if ( my $meta = eval { CPAN::Meta->load_file($source) } ) { + $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); + } +} +else { + $source = 'static metadata'; +} + +my @full_reports; +my @dep_errors; +my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs; + +# Add static includes into a fake section +for my $mod (@include) { + $req_hash->{other}{modules}{$mod} = 0; +} + +for my $phase ( qw(configure build test runtime develop other) ) { + next unless $req_hash->{$phase}; + next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING}); + + for my $type ( qw(requires recommends suggests conflicts modules) ) { + next unless $req_hash->{$phase}{$type}; + + my $title = ucfirst($phase).' '.ucfirst($type); + my @reports = [qw/Module Want Have/]; + + for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { + next if $mod eq 'perl'; + next if grep { $_ eq $mod } @exclude; + + my $file = $mod; + $file =~ s{::}{/}g; + $file .= ".pm"; + my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; + + my $want = $req_hash->{$phase}{$type}{$mod}; + $want = "undef" unless defined $want; + $want = "any" if !$want && $want == 0; + + my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; + + if ($prefix) { + my $have = MM->parse_version( File::Spec->catfile($prefix, $file) ); + $have = "undef" unless defined $have; + push @reports, [$mod, $want, $have]; + + if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) { + if ( $have !~ /\A$lax_version_re\z/ ) { + push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)"; + } + elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) { + push @dep_errors, "$mod version '$have' is not in required range '$want'"; + } + } + } + else { + push @reports, [$mod, $want, "missing"]; + + if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) { + push @dep_errors, "$mod is not installed ($req_string)"; + } + } + } + + if ( @reports ) { + push @full_reports, "=== $title ===\n\n"; + + my $ml = _max( map { length $_->[0] } @reports ); + my $wl = _max( map { length $_->[1] } @reports ); + my $hl = _max( map { length $_->[2] } @reports ); + + if ($type eq 'modules') { + splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl]; + push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports; + } + else { + splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl]; + push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports; + } + + push @full_reports, "\n"; + } + } +} + +if ( @full_reports ) { + diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports; +} + +if ( @dep_errors ) { + diag join("\n", + "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n", + "The following REQUIRED prerequisites were not satisfied:\n", + @dep_errors, + "\n" + ); +} + +pass; + +# vim: ts=4 sts=4 sw=4 et: diff --git a/t/01-utf8-all.t b/t/01-utf8-all.t new file mode 100644 index 0000000..4acd4e9 --- /dev/null +++ b/t/01-utf8-all.t @@ -0,0 +1,24 @@ +use strict; +use warnings; + +use Test::More; +use Parallel::ForkManager; + +plan skip_all => 'This is a bug in perl itself on Windows' if $^O eq 'MSWin32'; +# It is broken on 5.16.2 and on blead Perl: +# It was reported to the Perl 5 porters: +# http://www.nntp.perl.org/group/perl.perl5.porters/2012/12/msg196821.html + +eval "use utf8::all"; +plan skip_all => 'Need utf8::all for this test crashing on Windows' if ($@); +plan tests => 1; + +my $fork = Parallel::ForkManager->new( 1 ); +foreach (1) { + my $pid = $fork->start and next; + $fork->finish; +} +$fork->wait_all_children; + +ok(1); + diff --git a/t/02-callback.t b/t/02-callback.t new file mode 100644 index 0000000..652aa00 --- /dev/null +++ b/t/02-callback.t @@ -0,0 +1,22 @@ +use strict; +use warnings; + +use Test::More tests => 2; + +diag 'This test can take 10-20 seconds, please wait. Started at ' . localtime; + +my @out = qx{$^X -Ilib examples/callback.pl}; +$_ =~ s/pid:\s*-?\d+/pid:/g for @out; +$_ =~ s/PID\s*-?\d+/PID/g for @out; +my @wait = grep { /Have to wait for one children/ } @out; +@out = grep { !/Have to wait for one children/ } @out; +@out = sort @out; +cmp_ok scalar(@wait), '>', 10, 'Have to wait for one children at least 10 times'; + + +my @expected = do { open my $fh, '<', 't/callback.txt'; <$fh> }; +$_ =~ s/pid:\s*-?\d+/pid:/g for @expected; +$_ =~ s/PID\s*-?\d+/PID/g for @expected; +@expected = sort @expected; +is_deeply \@out, \@expected, 'callback worked' or diag explain @out; + diff --git a/t/03-callback-data.t b/t/03-callback-data.t new file mode 100644 index 0000000..fc567ff --- /dev/null +++ b/t/03-callback-data.t @@ -0,0 +1,29 @@ +use strict; +use warnings; + +use Test::More 0.94 tests => 2; +use File::Temp qw(tempdir); + +diag 'This test can take 2-6 seconds, please wait. Started at ' . localtime; + + +my @expected = do { open my $fh, '<', 't/callback_data.txt'; <$fh> }; +@expected = sort @expected; + + +subtest direct => sub { + my @out = sort qx{$^X -Ilib examples/callback_data.pl}; + is_deeply \@out, \@expected, 'callback_data worked' or diag explain @out; +}; + +subtest tempdir => sub { + my $dir = tempdir( CLEANUP => 1 ); + my $tempdir = "$dir/abc"; + mkdir $tempdir; + my @out = sort qx{$^X -Ilib examples/callback_data.pl $tempdir}; + is_deeply \@out, \@expected, 'callback_data worked' or diag explain @out; + ok -d $tempdir, 'tempdir was left there'; +}; + + + diff --git a/t/basic-methods.t b/t/basic-methods.t new file mode 100644 index 0000000..ab100d3 --- /dev/null +++ b/t/basic-methods.t @@ -0,0 +1,38 @@ +use strict; +use warnings; + +use Test::More tests => 8; + +use Parallel::ForkManager; + +my $pm = Parallel::ForkManager->new(4); + +for(1..3) { + $pm->start and next; + sleep $_; + $pm->finish; +} + +my $nbr = $pm->running_procs; +my @pids = $pm->running_procs; + +is $pm->max_procs => 4, 'max procs is 4'; + +is $nbr => 3, '3 children'; + +is scalar(@pids) => 3, '3 children'; + +# on Windows they'll be negative +like $_ => qr/^-?\d+$/, "looks like a pid" for @pids; + +$pm->wait_for_available_procs(3); + +is $pm->running_procs => 1, 'only one process left'; + +$pm->wait_all_children; + +is $pm->running_procs => 0, "all done"; + + + + diff --git a/t/callback.txt b/t/callback.txt new file mode 100644 index 0000000..d7a8a45 --- /dev/null +++ b/t/callback.txt @@ -0,0 +1,26 @@ +** Bob just got out of the pool with PID 23400 and exit code: 5 +** Bob started, pid: 23400 +** Fred just got out of the pool with PID 23395 and exit code: 0 +** Fred started, pid: 23395 +** Jessica just got out of the pool with PID 23399 and exit code: 4 +** Jessica started, pid: 23399 +** Jim just got out of the pool with PID 23396 and exit code: 1 +** Jim started, pid: 23396 +** Lily just got out of the pool with PID 23397 and exit code: 2 +** Lily started, pid: 23397 +** Steve just got out of the pool with PID 23398 and exit code: 3 +** Steve started, pid: 23398 +Bob, Child 5 is about to get out... +Everybody is out of the pool! +Fred, Child 0 is about to get out... +Jessica, Child 4 is about to get out... +Jim, Child 1 is about to get out... +Lily, Child 2 is about to get out... +Steve, Child 3 is about to get out... +This is Bob, Child number 5 +This is Fred, Child number 0 +This is Jessica, Child number 4 +This is Jim, Child number 1 +This is Lily, Child number 2 +This is Steve, Child number 3 +Waiting for Children... diff --git a/t/callback_data.txt b/t/callback_data.txt new file mode 100644 index 0000000..ec12c21 --- /dev/null +++ b/t/callback_data.txt @@ -0,0 +1,5 @@ +Fred started +Jim started +Fred just got out of the pool with exit code: 0 and data: Fred 4 +Jim just got out of the pool with exit code: 1 and data: Jim 3 +Everybody is out of the pool! diff --git a/t/changing-pids.t b/t/changing-pids.t new file mode 100644 index 0000000..e6a4c57 --- /dev/null +++ b/t/changing-pids.t @@ -0,0 +1,26 @@ +use strict; +use warnings; + +use Test::More tests => 1; +use Parallel::ForkManager; + +my $data; + +my $inner = Parallel::ForkManager->new(1); +$inner->run_on_finish(sub{ $data = $_[5]; }); + +my $outer = Parallel::ForkManager->new(1); +$outer->run_on_finish(sub{ $data = $_[5]; }); + +unless( $outer->start ) { + unless( $inner->start ) { + $inner->finish( 0, [ 'yay' ] ); + } + $inner->wait_all_children; + + $outer->finish(0, $data ); +} + +$outer->wait_all_children; + +ok $data, "received reference"; diff --git a/t/start_child.t b/t/start_child.t new file mode 100644 index 0000000..792d5e3 --- /dev/null +++ b/t/start_child.t @@ -0,0 +1,57 @@ +use strict; +use warnings; + +use Test::More tests => 2; + +use Parallel::ForkManager; + +subtest 'classic' => sub { + my @results; + + my $fm = Parallel::ForkManager->new(4); + + @results = (); + + $fm->run_on_finish(sub{ + push @results, @{$_[5]}; + }); + + for ( 1..5 ) { + $fm->start and next; + $fm->finish(0, [ $_ ]); + } + + $fm->wait_all_children; + + is_deeply [ sort @results ] => [ 1..5 ], 'get expected results'; +}; + +subtest 'callback' => sub { + my @results; + + my $fm = Parallel::ForkManager->new(4); + + @results = (); + + $fm->run_on_finish(sub{ + push @results, @{$_[5]}; + }); + + for ( 1..5 ) { + $fm->start_child(sub{ + return [ $_ ]; + }); + } + + $fm->wait_all_children; + + is_deeply [ sort @results ] => [ 1..5 ], 'get expected results'; +}; + + + + + + + + diff --git a/t/waitpid-conflict.t b/t/waitpid-conflict.t new file mode 100644 index 0000000..dcae56f --- /dev/null +++ b/t/waitpid-conflict.t @@ -0,0 +1,38 @@ +use strict; +use warnings; + +use Test::More; + +use Parallel::ForkManager; + +my $pm = Parallel::ForkManager->new(4); + +local $SIG{ALRM} = sub { + fail "test hanging, forever waiting for child process"; + exit 1; +}; + +for ( 1 ) { + $pm->start and next; + sleep 2; + $pm->finish; +} + +my $pid = waitpid -1, 0; + +diag "code outside of P::FM stole $pid"; + +TODO: { + local $TODO = 'MacOS and FreeBDS seem to have issues with this'; + + eval { + alarm 10; + $pm->wait_all_children; + pass "wait_all_children terminated"; + }; + + is $pm->running_procs => 0, "all children are accounted for"; + +} + +done_testing; diff --git a/t/waitpid-waitonechild.t b/t/waitpid-waitonechild.t new file mode 100644 index 0000000..a84ea4e --- /dev/null +++ b/t/waitpid-waitonechild.t @@ -0,0 +1,42 @@ +use strict; +use warnings; + +use Test::More; +use Test::Warn; + +use Parallel::ForkManager; + +my $pm = Parallel::ForkManager->new(4); + +local $SIG{ALRM} = sub { + fail "test hanging, forever waiting for child process"; + exit 1; +}; + +for ( 1 ) { + $pm->start and last; + sleep 2; + $pm->finish; +} + +my $pid = waitpid -1, 0; + +diag "code outside of P::FM stole $pid"; + +TODO: { + local $TODO = 'MacOS and FreeBDS seem to have issues with this'; + + eval { + alarm 10; + warning_like { + $pm->wait_one_child; + } qr/child process '\d+' disappeared. A call to `waitpid` outside of Parallel::ForkManager might have reaped it\./, + "got the missing child warning"; + pass "wait_one_child terminated"; + }; + + is $pm->running_procs => 0, "all children are accounted for"; + +} + +done_testing; diff --git a/t/waitpid_blocking.t b/t/waitpid_blocking.t new file mode 100644 index 0000000..5eabf39 --- /dev/null +++ b/t/waitpid_blocking.t @@ -0,0 +1,31 @@ +use strict; +use warnings; + +use Test::More tests => 1; + +use Parallel::ForkManager; + +my $pm = Parallel::ForkManager->new(2); + +$pm->set_waitpid_blocking_sleep(5); +my $start = time; + +for(1) { + $pm->start and last; + sleep 1; + $pm->finish; +} + +$pm->wait_one_child; + +# if the sleep works correctly, we shouldn't +# check if the child is gone before 5 seconds +# in the future + +cmp_ok abs( 5 - time + $start ), '<=', 2; + + + + + + diff --git a/xt/release/pause-permissions.t b/xt/release/pause-permissions.t new file mode 100644 index 0000000..e18e9a9 --- /dev/null +++ b/xt/release/pause-permissions.t @@ -0,0 +1,13 @@ +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::PAUSE::Permissions 0.002 + +use Test::More; +BEGIN { + plan skip_all => 'Test::PAUSE::Permissions required for testing pause permissions' + if $] < 5.010; +} +use Test::PAUSE::Permissions; + +all_permissions_ok('yanick'); diff --git a/xt/release/unused-vars.t b/xt/release/unused-vars.t new file mode 100644 index 0000000..e601076 --- /dev/null +++ b/xt/release/unused-vars.t @@ -0,0 +1,14 @@ +#!perl + +use Test::More 0.96 tests => 1; +eval { require Test::Vars }; + +SKIP: { + skip 1 => 'Test::Vars required for testing for unused vars' + if $@; + Test::Vars->import; + + subtest 'unused vars' => sub { +all_vars_ok(); + }; +};