MCE-1.810/0000755000175000017500000000000013022753214011126 5ustar mariomarioMCE-1.810/LICENSE0000644000175000017500000001425713006204541012140 0ustar mariomario The "Artistic License" Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder as specified below. "Copyright Holder" is whoever is named in the copyright or copyrights for the package. "You" is you, if you're thinking about copying or distributing this Package. "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as uunet.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) give non-standard executables non-standard names, and clearly document the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whoever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End MCE-1.810/Makefile.PL0000644000175000017500000001146513022712316013105 0ustar mariomario # Module makefile for MCE (using ExtUtils::MakeMaker) use 5.008; use strict; use warnings; use ExtUtils::MakeMaker; my @exe_files; if ($ENV{MCE_INSTALL_TOOLS}) { push @exe_files, 'bin/mce_grep'; } WriteMakefile( ABSTRACT => 'Many-Core Engine for Perl providing parallel processing capabilities', AUTHOR => 'Mario E. Roy ', NAME => 'MCE', VERSION => '1.810', EXE_FILES => [ @exe_files ], NO_META => 1, PREREQ_PM => { 'base' => 0, 'bytes' => 0, 'constant' => 0, 'strict' => 0, 'warnings' => 0, 'Carp' => 0, 'Fcntl' => 0, 'File::Path' => 0, 'Getopt::Long' => 0, 'IO::Handle' => 0, 'Scalar::Util' => 0, 'Socket' => 0, 'Storable' => 2.04, 'Symbol' => 0, 'Time::HiRes' => 0 }, ((!eval { ExtUtils::MakeMaker->VERSION(6.25) } ) ? ( PL_FILES => {} ) : () ), (( eval { ExtUtils::MakeMaker->VERSION(6.31) } ) ? ( LICENSE => 'perl' ) : () ), (( eval { ExtUtils::MakeMaker->VERSION(6.46) } ) ? ( META_MERGE => { 'build_requires' => { 'ExtUtils::MakeMaker' => 0, 'Test::More' => 0.88 }, 'no_index' => { 'file' => [ 'bin/mce_grep' ] }, 'resources' => { 'bugtracker' => 'https://github.com/marioroy/mce-perl/issues', 'homepage' => 'https://github.com/marioroy/mce-perl', 'license' => 'http://dev.perl.org/licenses/', 'repository' => 'https://github.com/marioroy/mce-perl.git' }, 'provides' => { 'MCE' => { 'file' => 'lib/MCE.pm', 'version' => '1.810' }, 'MCE::Candy' => { 'file' => 'lib/MCE/Candy.pm', 'version' => '1.810' }, 'MCE::Core::Input::Generator' => { 'file' => 'lib/MCE/Core/Input/Generator.pm', 'version' => '1.810' }, 'MCE::Core::Input::Handle' => { 'file' => 'lib/MCE/Core/Input/Handle.pm', 'version' => '1.810' }, 'MCE::Core::Input::Iterator' => { 'file' => 'lib/MCE/Core/Input/Iterator.pm', 'version' => '1.810' }, 'MCE::Core::Input::Request' => { 'file' => 'lib/MCE/Core/Input/Request.pm', 'version' => '1.810' }, 'MCE::Core::Input::Sequence' => { 'file' => 'lib/MCE/Core/Input/Sequence.pm', 'version' => '1.810' }, 'MCE::Core::Manager' => { 'file' => 'lib/MCE/Core/Manager.pm', 'version' => '1.810' }, 'MCE::Core::Validation' => { 'file' => 'lib/MCE/Core/Validation.pm', 'version' => '1.810' }, 'MCE::Core::Worker' => { 'file' => 'lib/MCE/Core/Worker.pm', 'version' => '1.810' }, 'MCE::Flow' => { 'file' => 'lib/MCE/Flow.pm', 'version' => '1.810' }, 'MCE::Grep' => { 'file' => 'lib/MCE/Grep.pm', 'version' => '1.810' }, 'MCE::Loop' => { 'file' => 'lib/MCE/Loop.pm', 'version' => '1.810' }, 'MCE::Map' => { 'file' => 'lib/MCE/Map.pm', 'version' => '1.810' }, 'MCE::Mutex' => { 'file' => 'lib/MCE/Mutex.pm', 'version' => '1.810' }, 'MCE::Queue' => { 'file' => 'lib/MCE/Queue.pm', 'version' => '1.810' }, 'MCE::Relay' => { 'file' => 'lib/MCE/Relay.pm', 'version' => '1.810' }, 'MCE::Signal' => { 'file' => 'lib/MCE/Signal.pm', 'version' => '1.810' }, 'MCE::Step' => { 'file' => 'lib/MCE/Step.pm', 'version' => '1.810' }, 'MCE::Stream' => { 'file' => 'lib/MCE/Stream.pm', 'version' => '1.810' }, 'MCE::Subs' => { 'file' => 'lib/MCE/Subs.pm', 'version' => '1.810' }, 'MCE::Util' => { 'file' => 'lib/MCE/Util.pm', 'version' => '1.810' } } } ) : () ), (( eval { ExtUtils::MakeMaker->VERSION(6.48) } ) ? ( MIN_PERL_VERSION => 5.008 ) : () ), INSTALLDIRS => ( ($] < 5.011) ? 'perl' : 'site' ) ); MCE-1.810/README.md0000644000175000017500000001237213022712322012405 0ustar mariomario## Many-Core Engine for Perl This document describes MCE version 1.810. Many-Core Engine (MCE) for Perl helps enable a new level of performance by maximizing all available cores. ![ScreenShot](https://raw.githubusercontent.com/marioroy/mce-assets/master/images_README/MCE.png) ### Description MCE spawns a pool of workers and therefore does not fork a new process per each element of data. Instead, MCE follows a bank queuing model. Imagine the line being the data and bank-tellers the parallel workers. MCE enhances that model by adding the ability to chunk the next n elements from the input stream to the next available worker. ![ScreenShot](https://raw.githubusercontent.com/marioroy/mce-assets/master/images_README/Bank_Queuing_Model.png) ### Synopsis This is a simplistic use case of MCE running with 5 workers. ```perl # Construction using the Core API use MCE; my $mce = MCE->new( max_workers => 5, user_func => sub { my ($mce) = @_; $mce->say("Hello from " . $mce->wid); } ); $mce->run; # Construction using a MCE model use MCE::Flow max_workers => 5; mce_flow sub { my ($mce) = @_; MCE->say("Hello from " . MCE->wid); }; ``` The following is a demonstration for parsing a huge log file in parallel. ```perl use MCE::Loop; MCE::Loop::init { max_workers => 8, use_slurpio => 1 }; my $pattern = 'something'; my $hugefile = 'very_huge.file'; my @result = mce_loop_f { my ($mce, $slurp_ref, $chunk_id) = @_; # Quickly determine if a match is found. # Process the slurped chunk only if true. if ($$slurp_ref =~ /$pattern/m) { my @matches; # The following is fast on Unix, but performance degrades # drastically on Windows beyond 4 workers. open my $MEM_FH, '<', $slurp_ref; binmode $MEM_FH, ':raw'; while (<$MEM_FH>) { push @matches, $_ if (/$pattern/); } close $MEM_FH; # Therefore, use the following construction on Windows. while ( $$slurp_ref =~ /([^\n]+\n)/mg ) { my $line = $1; # save $1 to not lose the value push @matches, $line if ($line =~ /$pattern/); } # Gather matched lines. MCE->gather(@matches); } } $hugefile; print join('', @result); ``` The next demonstration loops through a sequence of numbers with MCE::Flow. ```perl use MCE::Flow; my $N = shift || 4_000_000; sub compute_pi { my ( $beg_seq, $end_seq ) = @_; my ( $pi, $t ) = ( 0.0 ); foreach my $i ( $beg_seq .. $end_seq ) { $t = ( $i + 0.5 ) / $N; $pi += 4.0 / ( 1.0 + $t * $t ); } MCE->gather( $pi ); } # Compute bounds only, workers receive [ begin, end ] values MCE::Flow::init( chunk_size => 200_000, max_workers => 8, bounds_only => 1 ); my @ret = mce_flow_s sub { compute_pi( $_->[0], $_->[1] ); }, 0, $N - 1; my $pi = 0.0; $pi += $_ for @ret; printf "pi = %0.13f\n", $pi / $N; # 3.1415926535898 ``` ### Installation and Dependencies To install this module type the following: MCE_INSTALL_TOOLS=1 perl Makefile.PL (for bin/mce_grep) (or) perl Makefile.PL make make test make install This module requires Perl 5.8.0 or later to run. By default, MCE spawns threads on Windows and child processes otherwise for Cygwin and Unix platforms. The use of threads requires that you include threads support prior to loading MCE. processes use threads; use forks; (or) use threads::shared; (or) use forks::shared; use MCE; use MCE; use MCE; ![ScreenShot](https://raw.githubusercontent.com/marioroy/mce-assets/master/images_README/Supported_OS.png) MCE utilizes the following modules, which are typically installed with Perl: bytes constant Carp Fcntl File::Path IO::Handle Scalar::Util Socket Storable 2.04+ Symbol Test::More 0.45+ (for make test only) Time::HiRes ### Further Reading The Perl MCE module is described at https://metacpan.org/pod/MCE. See [MCE::Examples](https://metacpan.org/pod/MCE::Examples) and [MCE Cookbook](https://github.com/marioroy/mce-cookbook) for recipes. ### Copyright and Licensing Copyright (C) 2012-2016 by Mario E. Roy This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself: a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" which comes with this Kit. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the GNU General Public License or the Artistic License for more details. You should have received a copy of the Artistic License with this Kit, in the file named "LICENSE". If not, I'll be glad to provide one. You should also have received a copy of the GNU General Public License along with this program in the file named "Copying". If not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA or visit their web page on the internet at http://www.gnu.org/copyleft/gpl.html. MCE-1.810/bin/0000755000175000017500000000000013022753214011676 5ustar mariomarioMCE-1.810/bin/mce_grep0000755000175000017500000006530113006204541013406 0ustar mariomario#!/usr/bin/env perl ############################################################################### ## ---------------------------------------------------------------------------- ## A MCE-driven wrapper script for the following C binaries. ## ## agrep.exe grep.exe egrep.exe fgrep.exe tre-agrep.exe ## agrep grep egrep fgrep tre-agrep ## ## Caveat for grep, egrep, fgrep. MCE chunks input while running which may ## cause the following options to report inaccurately. It's possible that ## the requested NUM lines may cross chunking boundaries. Specify a larger ## chunk size value to minimize the effect or pass --chunk-level=list. ## ## -A NUM, --after-context=NUM ## -B NUM, --before-context=NUM ## -C NUM, --context=NUM ## ## Simply copy/rename this script or create a link to it. The prefix 'mce_' is ## stripped from the name for determining the actual binary to use. A trailing ## '.pl' extension is optional. Please ensure the binary is installed and in ## your path. ## ## ln mce_grep mce_agrep (or) ln -s mce_grep mce_agrep.pl ## ln mce_grep mce_tre-agrep (or) cp mce_grep mce_tre-agrep.pl ## ln mce_grep mce_egrep ## ln mce_grep mce_fgrep ## ## Which to choose (examples/egrep.pl or bin/mce_grep). ## ## Examples/egrep.pl is a pure Perl implementation with fewer options. ## Bin/mce_grep is a wrapper script for the relevant binary. ## ## The wrapper script is good for expensive pattern matching -- especially ## for agrep and tre-agrep. It also supports more options due to being ## passed to the binary. The wrapper supports 2 levels of chunking via the ## --chunk-level={auto|file|list} option. For large files, choose file. ## ## ============================================================================ ## 2014-01-21 v1.008 ## Created by Mario Roy. ## ## 2014-07-23 v1.009 ## ${^CHILD_ERROR_NATIVE} is not defined in Perl 5.8.x. Use $? instead. ## Compute chunk_level => 'auto' to use 'file' when reading STDIN. ## Set chunk_size to 8M when not specified (from 4M previously). ## ## 2014-12-22 v1.010 ## Small code refactoring. ## ############################################################################### use strict; use warnings; ## no critic (InputOutput::ProhibitBarewordFileHandles) ## no critic (InputOutput::ProhibitTwoArgOpen) use Cwd 'abs_path'; ## Insert lib-path at the head of @INC. use lib abs_path($0 =~ m{^(.*)[\\/]} && $1 || abs_path) . '/../lib'; my ($prog_name, $prog_dir); BEGIN { $prog_name = $0; $prog_name =~ s{^.*[\\/]}{}g; $prog_dir = abs_path($0); $prog_dir =~ s{[\\/][^\\/]*$}{}; $ENV{PATH} .= ($^O eq 'MSWin32' ? ';' : ':') . $prog_dir; } sub INIT { ## Provide file globbing support under Windows similar to Unix. @ARGV = <@ARGV> if ($^O eq 'MSWin32'); } use Getopt::Long qw( :config bundling pass_through no_ignore_case no_auto_abbrev ); use Scalar::Util qw( looks_like_number ); use Fcntl qw( O_RDONLY ); use MCE::Signal qw( -use_dev_shm ); use MCE 1.5; ############################################################################### ## ---------------------------------------------------------------------------- ## Usage and validation. ## ############################################################################### sub usage { print <<"::_USAGE_BLOCK_END_::"; Options for Script: --max-workers=NUM override max workers (default auto) e.g. auto, auto-2, 4 --chunk-level=LEVEL override chunk level (default auto) chunk at [file] or [list] level --chunk-size=NUM[KM] override chunk size (set at limit if under or over) [file] default: 8M minimum: 200K maximum: 20M [list] default: 12 minimum: 1 maximum: 60 --lang=LOCALE override locale e.g. C, en_US.UTF-8, en_US.ISO-8859-1 Options for Binary: ::_USAGE_BLOCK_END_:: return; } my $is_mswin32 = $^O eq 'MSWin32'; my ($cmd_name, $cmd_path); $cmd_name = $prog_name; $cmd_name =~ s{^mce_}{}; $cmd_name =~ s{\.pl$}{}; if ($is_mswin32) { $cmd_name .= '.exe'; for ( split ';', $ENV{'PATH'} ) { if (-x "$_\\$cmd_name") { $cmd_path = "$_\\$cmd_name"; last; } } } else { $cmd_name .= '.exe' if $^O eq 'cygwin'; for ( split ':', $ENV{'PATH'} ) { if (-x "$_/$cmd_name") { $cmd_path = "$_/$cmd_name"; last; } } } unless (defined $cmd_path) { print {*STDERR} "$prog_name: $cmd_name: command not found\n"; exit 2; } { my %valid_names = map { $_ => 1 } qw( agrep.exe grep.exe egrep.exe fgrep.exe tre-agrep.exe agrep grep egrep fgrep tre-agrep ); unless (exists $valid_names{$cmd_name}) { print {*STDERR} "$prog_name: $cmd_name: command not supported\n"; exit 2; } } ############################################################################### ## ---------------------------------------------------------------------------- ## Process arguments. ## ############################################################################### my ($h_patn, $b_flag, $c_flag, $H_flag, $h_flag, $n_flag, $q_flag) = ((0) x 7); my (@r_patn, @args, $arg, @files, $file); my ($f_list, $r_flag) = (0, 0); my ($exit_status, $found_match, $skip_args, $w_filename) = (0, 0, 0, 0); my $max_workers = 'auto'; my $chunk_level = 'auto'; my $chunk_size; my $max_count = 0; my $no_msg = 0; my @TMP_ARGV; ## Option parsing step 1. for my $i (0 .. @ARGV - 1) { if ($ARGV[$i] eq '--') { @TMP_ARGV = @ARGV[$i .. @ARGV - 1]; @ARGV = @ARGV[0 .. $i - 1]; last; } } { local $SIG{__WARN__} = sub { }; GetOptions( 'max-workers|max_workers=s' => \$max_workers, 'chunk-level|chunk_level=s' => \$chunk_level, 'chunk-size|chunk_size=s' => \$chunk_size, 'lang=s' => sub { my ($self, $lang) = @_; delete @ENV{ qw( LC_MESSAGES LC_COLLATE LC_CTYPE LC_ALL ) }; $ENV{'LANG'} = $lang; }, 'help' => sub { usage(); system $cmd_path, '--help'; print "\n"; exit 0; }, 'V|version' => sub { system $cmd_path, '--version'; exit 0; }, 'q|quiet|silent' => \$q_flag, 'H|with-filename' => sub { $H_flag = 1; $h_flag = 0; }, 'h|no-filename' => sub { $H_flag = 0; $h_flag = 1; }, 'm|max-count=s' => \$max_count, 'R|r|recursive' => \$r_flag ); if ($max_workers !~ /^auto/) { unless (looks_like_number($max_workers) && $max_workers > 0) { print {*STDERR} "$prog_name: invalid max workers\n"; exit 2; } } if ($chunk_level !~ /^(?:auto|file|list)$/) { print {*STDERR} "$prog_name: invalid chunk level\n"; exit 2; } if (defined $chunk_size) { if ($chunk_size =~ /^(\d+)K/i) { $chunk_size = $1 * 1024; } elsif ($chunk_size =~ /^(\d+)M/i) { $chunk_size = $1 * 1024 * 1024; } if (!looks_like_number($chunk_size) || $chunk_size < 1) { print {*STDERR} "$prog_name: invalid chunk size\n"; exit 2; } } if ($max_count) { unless (looks_like_number($max_count) && $max_count >= 0) { print {*STDERR} "$prog_name: invalid max count\n"; exit 2; } } } ## Option parsing step 2. if (@TMP_ARGV) { @ARGV = (@ARGV, @TMP_ARGV); undef @TMP_ARGV; if ($ARGV[0] eq '--') { shift @ARGV; $skip_args = 1; push @args, '--'; } } while ( @ARGV ) { $arg = shift @ARGV; $arg =~ s/ /\\ /g; if ($skip_args) { push @files, $arg; } elsif (substr($arg, 0, 2) eq '--') { ## --OPTION if ($arg eq '--') { $skip_args = 1; push @args, $arg; next; } $h_patn = 1 if $arg =~ /^--regexp=/; $h_patn = 1 if $arg =~ /^--file=/; $b_flag = 1 if $arg eq '--byte-offset'; $c_flag = 1 if $arg eq '--count'; $f_list = 1 if $arg eq '--files-without-match'; $f_list = 1 if $arg eq '--files-with-matches'; $n_flag = 1 if $arg eq '--record-number'; $n_flag = 1 if $arg eq '--line-number'; $no_msg = 1 if $arg eq '--no-messages'; if ($arg =~ /^--directories=(.+)/) { if ($1 ne 'recurse') { push @args, $arg; } else { $r_flag = 1; } } elsif ($arg =~ /^--include=.+/) { push @r_patn, $arg; } elsif ($arg =~ /^--exclude=.+/) { push @r_patn, $arg; } elsif ($arg =~ /^--exclude-from=.+/) { push @r_patn, $arg; } elsif ($arg =~ /^--exclude-dir=.+/) { push @r_patn, $arg; } else { ## Pass arguments to the C binary push @args, $arg; } } elsif (substr($arg, 0, 1) eq '-') { ## -OPTION if ($arg eq '-') { push @files, $arg; next; } my $len = length $arg; for (my $x = 1; $x < $len; $x++) { my $a = substr($arg, $x, 1); $f_list = 1 if $a eq 'L' || $a eq 'l'; $h_patn = 1 if $a eq 'e' || $a eq 'f'; $b_flag = 1 if $a eq 'b'; $c_flag = 1 if $a eq 'c'; $n_flag = 1 if $a eq 'n'; $no_msg = 1 if ($a eq 's' && $cmd_name !~ /agrep/); } next if $arg eq '-'; ## Pass arguments to the C binary if ($cmd_name =~ /agrep/) { push @args, $arg; if (substr($arg, -1) =~ /[efDISEd]/) { $arg = shift @ARGV; $arg =~ s/ /\\ /g; push @args, $arg; } } else { my $a = substr($arg, -1); push @args, $arg if ($arg ne '-d'); if ($a =~ /[efABCD]/) { $arg = shift @ARGV; $arg =~ s/ /\\ /g; push @args, $arg; } elsif ($a eq 'd') { $arg = shift @ARGV; if ($arg ne 'recurse') { push @args, '-d', $arg; } else { $r_flag = 1; } } } } else { ## FILE push @files, $arg; } } ## Option parsing step 3. push @args, shift @files if ($h_patn == 0 && @files > 0); if ((!$h_flag && @files > 1) || (!$h_flag && $r_flag) || $H_flag) { $w_filename = 1; } if (@args == 0) { system $cmd_path; exit 2; } ############################################################################### ## ---------------------------------------------------------------------------- ## MCE callback functions: Error, File, and Count. ## ############################################################################### my ($_order_id, %_tmp, %_nrecs, %_nsize, $_start_nrecs, $_start_nsize); my ($_abort_all, $_abort_job, $_total_found); sub _error { my ($msg) = @_; print {*STDERR} $msg; $exit_status = 2; return; } sub _abort_job { if (!$_abort_job) { MCE->abort; $_abort_job = $_total_found = $found_match = 1; $_abort_all = 1 if $q_flag; } return; } sub _output_cnt { my ($chunk_id, $out_file, @_rest) = @_; my $cnt; if (-s $out_file) { $found_match = 1; open my $fh, '<', $out_file; chomp($cnt = <$fh>); close $fh; $_total_found += $cnt; if ($q_flag && !$_abort_all) { MCE->abort; $_abort_all = $_abort_job = 1; } } unlink $out_file; return; } sub _set_found_match { $found_match = 1; return; } ############################################################################### ## ---------------------------------------------------------------------------- ## MCE callback function: Output without line-number or byte-offset ## ############################################################################### sub _output_n0 { my ($chunk_id, $out_file, @_rest) = @_; $_tmp{ $chunk_id } = $out_file; return unless exists $_tmp{ $_order_id }; do { my $out_file = $_tmp{ $_order_id }; if (!$_abort_job && -s $out_file) { my ($fh, $buffer); $found_match = 1; if ($q_flag) { unless ($_abort_all) { MCE->abort; $_abort_all = $_abort_job = 1; } } else { if ($w_filename) { open $fh, '<', $out_file; while (<$fh>) { print $file . ':' . $_; if ($max_count && ++$_total_found == $max_count) { MCE->abort; $_abort_job = 1; last; } } close $fh; } else { if ($max_count) { open $fh, '<', $out_file; while (<$fh>) { print $_; if ($max_count && ++$_total_found == $max_count) { MCE->abort; $_abort_job = 1; last; } } close $fh; } else { sysopen $fh, $out_file, O_RDONLY; sysread $fh, $buffer, -s $fh; close $fh; print $buffer; } } } } delete $_tmp{ $_order_id }; unlink $out_file; } while (exists $_tmp{ ++$_order_id }); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## MCE callback function: Output with line-number or byte-offset ## ############################################################################### sub _output_n1 { my ($chunk_id, $out_file, $n_records, $size) = @_; $_tmp{ $chunk_id } = $out_file; $_nsize{ $chunk_id } = $n_flag ? $n_records : $size; return unless exists $_tmp{ $_order_id }; do { my $out_file = $_tmp{ $_order_id }; if ($_order_id > 1) { $_start_nsize += $_nsize{ $_order_id - 1 }; delete $_nsize{ $_order_id - 1 }; } if (!$_abort_job && -s $out_file) { my ($p1, $size); $found_match = 1; if ($q_flag) { unless ($_abort_all) { MCE->abort; $_abort_all = $_abort_job = 1; } } else { open my $fh, '<', $out_file; if ($w_filename) { while (<$fh>) { $p1 = index($_, ':'); $size = $_start_nsize + substr($_, 0, $p1); print $file . ':' . $size . substr($_, $p1); if ($max_count && ++$_total_found == $max_count) { MCE->abort; $_abort_job = 1; last; } } } else { while (<$fh>) { $p1 = index($_, ':'); $size = $_start_nsize + substr($_, 0, $p1); print $size . substr($_, $p1); if ($max_count && ++$_total_found == $max_count) { MCE->abort; $_abort_job = 1; last; } } } close $fh; } } delete $_tmp{ $_order_id }; unlink $out_file; } while (exists $_tmp{ ++$_order_id }); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## MCE callback function: Output with line-number and byte-offset ## ############################################################################### sub _output_n2 { my ($chunk_id, $out_file, $n_records, $size) = @_; $_tmp{ $chunk_id } = $out_file; $_nrecs{ $chunk_id } = $n_records; $_nsize{ $chunk_id } = $size; return unless exists $_tmp{ $_order_id }; do { my $out_file = $_tmp{ $_order_id }; if ($_order_id > 1) { $_start_nrecs += $_nrecs{ $_order_id - 1 }; delete $_nrecs{ $_order_id - 1 }; $_start_nsize += $_nsize{ $_order_id - 1 }; delete $_nsize{ $_order_id - 1 }; } if (!$_abort_job && -s $out_file) { my ($p1, $p2, $recs, $size); $found_match = 1; if ($q_flag) { unless ($_abort_all) { MCE->abort; $_abort_all = $_abort_job = 1; } } else { open my $fh, '<', $out_file; if ($w_filename) { while (<$fh>) { $p1 = index($_, ':'); $recs = $_start_nrecs + substr($_, 0, $p1++); $p2 = index($_, ':', $p1); $size = $_start_nsize + substr($_, $p1, $p2 - $p1); print $file . ':' . $recs . ':' . $size . substr($_, $p2); if ($max_count && ++$_total_found == $max_count) { MCE->abort; $_abort_job = 1; last; } } } else { while (<$fh>) { $p1 = index($_, ':'); $recs = $_start_nrecs + substr($_, 0, $p1++); $p2 = index($_, ':', $p1); $size = $_start_nsize + substr($_, $p1, $p2 - $p1); print $recs . ':' . $size . substr($_, $p2); if ($max_count && ++$_total_found == $max_count) { MCE->abort; $_abort_job = 1; last; } } } close $fh; } } delete $_tmp{ $_order_id }; unlink $out_file; } while (exists $_tmp{ ++$_order_id }); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## MCE user functions: run-mode = file. ## ############################################################################### sub user_begin_file { $0 = $^X; return; } sub make_user_func_file { my $first_time = 1; return sub { my ($self, $chunk_ref, $chunk_id) = @_; my ($out_fh, $err_fh, $cmd_fh, $has_err); my $n_records = 0; my $out_file = MCE->sess_dir .'/'. $chunk_id; if ($n_flag) { $n_records++ while ($$chunk_ref =~ m!\n!mg); } if ($is_mswin32) { $out_file =~ s{/}{\\\\}g; open my $in_fh, '+>', $out_file . '.in'; binmode $in_fh, ':raw'; print {$in_fh} $$chunk_ref; close $in_fh; my $err_file = $first_time ? "2> $out_file.err" : ''; system("$cmd_path < $out_file.in @args > $out_file $err_file"); unlink "$out_file.in"; } else { ## I borrowed some bits from IPC::Run3 for STDOUT/ERR. However, I ## settled on passing STDIN via open for lesser overhead behind the ## scene versus calling system (from observation during testing). local (*STDOUT_SAVE, *STDERR_SAVE); open STDOUT_SAVE, '>&STDOUT'; open $out_fh, '+>', $out_file; binmode $out_fh, ':raw'; open STDOUT, '>&' . fileno $out_fh; if ($first_time) { open STDERR_SAVE, '>&STDERR'; open $err_fh, '+>', "$out_file.err"; binmode $err_fh, ':raw'; open STDERR, '>&' . fileno $err_fh; } ## Seeing "maximal count of pending signals (NUM) exceeded" message. ## Thus the reason for using syswrite instead of print below. open $cmd_fh, '|-', $cmd_path, @args; ## Run external command syswrite $cmd_fh, $$chunk_ref; ## Write to STDIN close $cmd_fh; open STDOUT, '>&STDOUT_SAVE'; close $out_fh; if ($first_time) { open STDERR, '>&STDERR_SAVE'; close $err_fh; } } MCE->abort if ($q_flag && -s $out_file); ## Send error. if ($first_time) { my $err_file = "$out_file.err"; if (-s $err_file) { $has_err = 1; MCE->abort; if ($chunk_id == 1) { open $err_fh, '<', $err_file; local $/ = undef; MCE->do('_error', <$err_fh>); close $err_fh; } } unlink $err_file; $first_time = 0; } ## Gather output. if ($f_list) { MCE->do('_abort_job') if (!$has_err && -s $out_file); unlink $out_file; } else { MCE->gather($chunk_id, $out_file, $n_records, length $$chunk_ref) unless $has_err; } return; }; } ############################################################################### ## ---------------------------------------------------------------------------- ## MCE user functions: run-mode = list. ## ############################################################################### sub user_begin_list { $0 = $^X; use vars qw( $child_found_match ); our $child_found_match = 0; return; } sub user_end_list { MCE->do('_set_found_match') if $child_found_match; return; } sub user_func_list { my ($self, $chunk_ref, $chunk_id) = @_; my ($output, $err_fh, $status); my $err_file = MCE->sess_dir .'/'. $chunk_id . '.err'; $$chunk_ref =~ s/\n/ /mg; local $?; if ($is_mswin32) { $err_file =~ s{/}{\\\\}g; $output = `$cmd_path @args $$chunk_ref 2> $err_file`; $status = $? >> 8; } else { local *STDERR_SAVE; open STDERR_SAVE, '>&STDERR'; open $err_fh, '+>', $err_file; binmode $err_fh, ':raw'; open STDERR, '>&' . fileno $err_fh; $output = `$cmd_path @args $$chunk_ref`; $status = $? >> 8; open STDERR, '>&STDERR_SAVE'; close $err_fh; } MCE->abort if ($q_flag && length $output); ## Send error. if (-s $err_file) { open $err_fh, '<', $err_file; local $/ = undef; MCE->do('_error', <$err_fh>); close $err_fh; } unlink $err_file; ## Gather output. if ($q_flag) { MCE->do('_abort_job') if ($status == 0); } else { if (length $output) { MCE->print($output); $child_found_match = 1; } } return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Process routines: run-mode = file. ## ############################################################################### sub process_file { ($file) = @_; if ($file eq '-') { open(STDIN, '<', ($is_mswin32) ? 'CON' : '/dev/tty') or die $!; process_stdin(); } elsif (! -e $file) { $exit_status = 2; print {*STDERR} "$prog_name: $file: No such file or directory\n" unless $no_msg; } elsif (-d $file) { $exit_status = 1; } else { $_abort_job = $_start_nrecs = $_start_nsize = $_total_found = 0; $_order_id = 1; MCE->process($file); %_nrecs = (); %_nsize = (); if (!$q_flag && $f_list) { print "$file\n" if $_total_found; } elsif (!$q_flag && $c_flag) { $_total_found = $max_count if ($max_count && $_total_found > $max_count); print "$file:" if $w_filename; print "$_total_found\n"; } } return; } sub process_stdin { $file = '(standard input)'; $_abort_job = $_start_nrecs = $_start_nsize = $_total_found = 0; $_order_id = 1; MCE->process(\*STDIN); %_nrecs = (); %_nsize = (); if (!$q_flag && $f_list) { print "$file\n" if $_total_found; } elsif (!$q_flag && $c_flag) { $_total_found = $max_count if ($max_count && $_total_found > $max_count); print "$file:" if $w_filename; print "$_total_found\n"; } return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Configure Many-Core Engine. ## ############################################################################### my $gather_func; if ($chunk_level eq 'auto') { if (@files == 0 || $files[0] eq '-') { $chunk_level = 'file'; } else { if (-f $files[0]) { $chunk_level = (-s $files[0] > 20_971_520) ? 'file' : 'list'; ## 20M } else { $chunk_level = 'list'; } } } if ($chunk_level eq 'list') { $chunk_size = 12 unless defined $chunk_size; $chunk_size = 60 if $chunk_size > 60; $chunk_size = 1 if $chunk_size < 1; unshift @args, '-H' if (!$h_flag && ($H_flag || $r_flag || @files > 1)); unshift @args, '-h' if ($h_flag); unshift @args, '-q' if ($q_flag); MCE->new( max_workers => $max_workers, chunk_size => $chunk_size, use_slurpio => 1, user_begin => \&user_begin_list, user_func => \&user_func_list, user_end => \&user_end_list ); } else { $chunk_size = 8_388_608 unless defined $chunk_size; ## 8M $chunk_size = 20_971_520 if $chunk_size > 20_971_520; ## 20M $chunk_size = 204_800 if $chunk_size < 204_800; ## 200K if ($f_list) { $gather_func = undef; } elsif ($c_flag) { $gather_func = \&_output_cnt; } elsif ($n_flag && $b_flag) { $gather_func = \&_output_n2; } elsif ($n_flag || $b_flag) { $gather_func = \&_output_n1; } else { $gather_func = \&_output_n0; } MCE->new( max_workers => $max_workers, chunk_size => $chunk_size, use_slurpio => 1, user_begin => \&user_begin_file, user_func => make_user_func_file(), gather => $gather_func ); } ############################################################################### ## ---------------------------------------------------------------------------- ## Run. ## ############################################################################### if ($r_flag && @files > 0) { my ($list_fh, $list); MCE->spawn; if ($is_mswin32) { $list = `egrep -lsr @r_patn ^ @files`; open $list_fh, '<', \$list; } else { open $list_fh, '-|', 'egrep', '-lsr', @r_patn, '^', @files; } if ($chunk_level eq 'list') { MCE->process($list_fh); } else { while (<$list_fh>) { chomp; process_file($_); last if $_abort_all; } } close $list_fh; } elsif (@files > 0) { if ($chunk_level eq 'list') { my $list = join("\n", @files) . "\n"; undef @files; open my $list_fh, '<', \$list; MCE->process($list_fh); close $list_fh; } else { foreach (@files) { process_file($_); last if $_abort_all; } } } else { if ($chunk_level eq 'list') { my $status = system($cmd_path, @args); exit($status >> 8); } else { process_stdin(); } } ############################################################################### ## ---------------------------------------------------------------------------- ## Finish. ## ############################################################################### MCE->shutdown; if (!$q_flag && $exit_status) { exit($exit_status); } else { exit($found_match ? 0 : ($exit_status ? $exit_status : 1)); } MCE-1.810/MANIFEST.SKIP0000644000175000017500000000070013006204541013015 0ustar mariomario ^# ^MANIFEST\. ^Makefile$ ~$ \.html$ \.old$ ^blib/ _blib$ ^MakeMaker-\d ^\.exists \bdebian\b \btest\b # Avoid version control files. \bRCS\b \bCVS\b ,v$ \B\.svn\b \B\.git\b \B\.gitignore\b # Avoid Makemaker generated and utility files. \bMANIFEST\.bak \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib$ # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ # Avoid temp and backup files. ~$ \.bak$ \.old$ \.tmp$ \#$ \b\.# \.gz$ MCE-1.810/Credits0000644000175000017500000002317513006204541012452 0ustar mariomario All the people reporting problems and fixes or solutions. More specifically in alphabetical order by last name. ############################################################################### # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # ############################################################################### Berger, Joel The inspiration for the sixth model (MCE::Step) came from reading a blog by Joel, "Writing Non-Blocking Applications with Mojolicious: Part 3": http://blogs.perl.org/users/joel_berger/2014/01/ writing-non-blocking-applications-with-mojolicious-part-3.html Bouras, George For reporting sockets failing under the Windows environment due to a period of inactivity. An example is when workers execute an external command taking beyond 4 minutes to complete. On returning, the sockets have gone stale with a CPU core going 100% at that point. The MCE 1.601 release is attributed to the many use cases I received from George. Cantrell, David (DrHyde on perlmonks.org) For reporting on MCE hanging with cpan -t MCE under his environment. Also, thank you for providing me a guest account via ssh. I was able to reproduce the issue. Thus, added writeable check and croak if tmp dir is not writeable. One cannot assume that /dev/shm is writeable by everyone. :) Collet, Eric For the inspiration to the tre-agrep binary. I first learned of tre-agrep from Eric. He emailed me running times for a couple scenarios utilizing a single core. Thus increasing the need to have a MCE-driven wrapper to run tre-agrep in parallel. The bin/mce_grep script was created to show folks how one may go about chunking data between Perl and an external C binary efficiently without invoking the shell. The script supports grep, egrep, fgrep, agrep and tre-agrep. Eldai, Hisham While working on the biofasta examples, Hisham introduced me to hg19.fa. A couple records inside hg19 (driven by $/ = "\n>") are 250 MiB in size. Memory optimizations in v1.600 came about by running against hg19.fa hundreds of times. ############################################################################### # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # ############################################################################### Farrell, David David wrote a nice article about MCE (love the picture). What stood out was his example. I never thought about using mce_grep { ... } <$fileHandle> without the _f (mce_grep_f). At the time, updated MCE::Grep and MCE::Map to be fully aware of wantarray. The blog "Make your code run faster with Perl's secret turbo module" is located at: http://perltricks.com/article/61/2014/1/21/ Make-your-code-run-faster-with-Perl-s-secret-turbo-module Golden, David For the Hash::Ordered module. I learned a lot from this *GEM* on CPAN. Particularly, the use of overload. I didn't know that was possible. For the time during collaborative efforts in making Hash::Ordered faster. I learned some new tricks along the way. Thank you for alarming me of the memory leaks with the on-demand hash dereferencing inside MCE::Shared::Ordhash. MCE::Shared::Object was also impacted. I'd never forget that dreadful day. MCE::Shared::{ Array, Hash, and Ordhash } are inspired by Hash::Ordered. In particular, the clone and iterator methods. Also, keys and values on taking arguments. I confess for never getting used to the "as_list" method name, initially. :) Gorwits, Oliver For reporting on a couple issues with MCE along with a solution for each. Pointed me in the right direction for improving the logic for the die handler. Basically, eval { die 'this should not cause MCE to die' }; This has reached 100% (all cases, threads and processes) in MCE 1.600. Halpenny, Shawn For reporting an issue (bug RT#94706) with signal handling in MCE::Signal. Also, thank you for tip on getpgrp. Hedden, Jerry From reading threads::shared. In particular the make_shared function. That was helpful in getting MCE::Shared working. Hluchan, Yary For providing a benchmark script which I used to compare IPC performance between 1.6 and 1.7. For many kind words near the end of the development cycle for MCE 1.7 and MCE::Shared. ############################################################################### # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # ############################################################################### Jacobsen, Dana For reporting an issue with get_ncpu on AIX. In addition, suggesting various solutions. Also, thank you for your time with Sandboxing with Perl + MCE + Inline::C at https://github.com/marioroy/mce-sandbox/. Karasik, Dmitry For bug (RT#102802) and elegant solution for the die handler inside MCE::Core::Worker and MCE::Signal. Kharchenko, Oleksandr Someone once asked Oleksandr why not use MCE. Oleksandr created 2 modules on CPAN, Parallel::DataPipe and Parallel::parallel_map. I used his example heavily in comparing IPC between pipe-driven and socket-driven. Not pleased with MCE's performance with chunk_size => 1, although 2 was as fast if not faster, I tried various things to include IO::Select. Finally, realized increasing the number of data channels was all that was needed (v1.500). Kulow, Stephan For making the OpenSUSE package for MCE. https://build.opensuse.org/package/show/devel:languages:perl:CPAN-M/perl-MCE Mabon, Philip For reporting on a couple issues with MCE in particular bug RT#92627. McKeown, Benjamin For reporting several edge cases with MCE in particular bugs RT#105557, RT#105559, and RT#111780. Mertens, David I am thankful for the tip on making PDL + MCE a possibility. Workers were crashing during exiting. Adding "sub PDL::CLONE_SKIP { 1 }" inside MCE.pm solved this issue entirely. Also, for tips on effectively using PDL in his example at https://gist.github.com/run4flat/4942132. Barrier synchronization in MCE came from reading parallel_sync in David's Perl module; PDL::Parallel::threads::SIMD. Mughal, Zakariyya First, Demian Riccardi introduced me to Devel::IPerl by Zakariyya. The die handlers in MCE broke the user experience. It seems that looking at $^S (for Perl state) is not enough. MCE v1.600 fixes this once and for all. The answer is in perl-5.20.1/cpan/CGI/lib/CGI/Carp.pm (Carp::longmess). ############################################################################### # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # ############################################################################### Ogulin, Joseph For providing the initial perl-MCE.spec file. For the cool remarks at work about MCE being really big :) Riccardi, Demian I received a message from Demian asking for mce_map. His message requested ( my @a = mce_map { ... } 1..100 ). Five models were introduced in v1.500; MCE::Flow, MCE::Grep, MCE::Loop, MCE::Map, and MCE::Stream. Find capability were limited in MCE::Shared 1.001. For example, not able to mix :AND(s) and :OR(s) together. One day, I clicked on recent distributions on metacpan.org and came across HackaMol::Roles::SelectionRole. The trick is to eval the query string together with grep or map. Thank you Demian. Rowe, Jillian For reporting on IO::File handles not working with MCE. Fixed in 1.515. For believing in possibilities beyond text-book thinking. Roy, Sylvia (spouse) For supporting me from v1.0, especially during later 1.6 revisions and 1.7. Šabata, Petr For initial package submission at Red Hat. https://bugzilla.redhat.com/show_bug.cgi?id=1162531 Sasser, Tom For reporting on bin/mce_grep failing with Perl 5.8.x. Schlichting, Florian For making a Debian package for MCE: http://pkgs.org/search/libmce-perl. Shen, Wei For the BioUtil CPAN module. BioUtil::Seq::FastaReader inspired me to create parallel examples (biofasta folder) in MCE 1.600. We tried to make FastaReader in BioUtil::Seq even faster. ############################################################################### # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # ############################################################################### Sjøgren, Adam For reporting on running /usr/bin/time mce_script.pl and pressing Ctrl-C failing. The default behavior in MCE::Signal is to call setpgrp. MCE 1.403 adds a new option to MCE::Signal to not call setpgrp. This also gives the developer finer control as to where setpgrp should be called, if ever needed, such as in the child process and not the manager process. use MCE::Signal qw(-no_setpgrp); use MCE; Smith, Marcus For reporting a problem with MCE including a sample script demonstrating MCE not 100% UTF-8 safe. All this time, totally overlooked the fact that the length function deals in logical characters, not physical bytes. :) Timmermans, Leon The inspiration for not having to backslash variables for MCE::Shared came from reading Const::Fast: e.g. mce_share my @array => ( list ); Thalhammer, Jeffrey Ryan For submitting a feature request for lazy arrays support. Although a lazy array cannot be used directly for input_data, support for iterator objects was added to MCE 1.505; e.g. input_data => $iterator_ref; This enabled support for lazy arrays using closures. I am thankful for the small code snippet highlighting a use-case of MCE. I would have failed initially without it. Your example was placed under the "SYNTAX for INPUT_DATA" section in MCE::Core for others to see on how to process output from Path::Iterator::Rule in parallel. Warm regards, Mario MCE-1.810/META.json0000644000175000017500000001017613022712266012556 0ustar mariomario{ "abstract" : "Many-Core Engine for Perl providing parallel processing capabilities", "author" : [ "Mario E. Roy " ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 6.55_02, CPAN::Meta::Converter version 2.150001", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "MCE", "no_index" : { "directory" : [ "t", "inc" ], "file" : [ "bin/mce_grep" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0", "Test::More" : "0.88", "perl" : "5.008" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0", "perl" : "5.008" } }, "runtime" : { "requires" : { "Carp" : "0", "Fcntl" : "0", "File::Path" : "0", "Getopt::Long" : "0", "IO::Handle" : "0", "Scalar::Util" : "0", "Socket" : "0", "Storable" : "2.04", "Symbol" : "0", "Time::HiRes" : "0", "base" : "0", "bytes" : "0", "constant" : "0", "perl" : "5.008", "strict" : "0", "warnings" : "0" } } }, "provides" : { "MCE" : { "file" : "lib/MCE.pm", "version" : "1.810" }, "MCE::Candy" : { "file" : "lib/MCE/Candy.pm", "version" : "1.810" }, "MCE::Core::Input::Generator" : { "file" : "lib/MCE/Core/Input/Generator.pm", "version" : "1.810" }, "MCE::Core::Input::Handle" : { "file" : "lib/MCE/Core/Input/Handle.pm", "version" : "1.810" }, "MCE::Core::Input::Iterator" : { "file" : "lib/MCE/Core/Input/Iterator.pm", "version" : "1.810" }, "MCE::Core::Input::Request" : { "file" : "lib/MCE/Core/Input/Request.pm", "version" : "1.810" }, "MCE::Core::Input::Sequence" : { "file" : "lib/MCE/Core/Input/Sequence.pm", "version" : "1.810" }, "MCE::Core::Manager" : { "file" : "lib/MCE/Core/Manager.pm", "version" : "1.810" }, "MCE::Core::Validation" : { "file" : "lib/MCE/Core/Validation.pm", "version" : "1.810" }, "MCE::Core::Worker" : { "file" : "lib/MCE/Core/Worker.pm", "version" : "1.810" }, "MCE::Flow" : { "file" : "lib/MCE/Flow.pm", "version" : "1.810" }, "MCE::Grep" : { "file" : "lib/MCE/Grep.pm", "version" : "1.810" }, "MCE::Loop" : { "file" : "lib/MCE/Loop.pm", "version" : "1.810" }, "MCE::Map" : { "file" : "lib/MCE/Map.pm", "version" : "1.810" }, "MCE::Mutex" : { "file" : "lib/MCE/Mutex.pm", "version" : "1.810" }, "MCE::Queue" : { "file" : "lib/MCE/Queue.pm", "version" : "1.810" }, "MCE::Relay" : { "file" : "lib/MCE/Relay.pm", "version" : "1.810" }, "MCE::Signal" : { "file" : "lib/MCE/Signal.pm", "version" : "1.810" }, "MCE::Step" : { "file" : "lib/MCE/Step.pm", "version" : "1.810" }, "MCE::Stream" : { "file" : "lib/MCE/Stream.pm", "version" : "1.810" }, "MCE::Subs" : { "file" : "lib/MCE/Subs.pm", "version" : "1.810" }, "MCE::Util" : { "file" : "lib/MCE/Util.pm", "version" : "1.810" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/marioroy/mce-perl/issues" }, "homepage" : "https://github.com/marioroy/mce-perl", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/marioroy/mce-perl.git" } }, "version" : "1.810" } MCE-1.810/META.yml0000644000175000017500000000507013022712302012372 0ustar mariomario--- abstract: 'Many-Core Engine for Perl providing parallel processing capabilities' author: - 'Mario E. Roy ' build_requires: ExtUtils::MakeMaker: '0' Test::More: '0.88' perl: '5.008' configure_requires: ExtUtils::MakeMaker: '0' perl: '5.008' dynamic_config: 0 generated_by: 'ExtUtils::MakeMaker version 6.55_02, 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: MCE no_index: directory: - t - inc file: - bin/mce_grep provides: MCE: file: lib/MCE.pm version: '1.810' MCE::Candy: file: lib/MCE/Candy.pm version: '1.810' MCE::Core::Input::Generator: file: lib/MCE/Core/Input/Generator.pm version: '1.810' MCE::Core::Input::Handle: file: lib/MCE/Core/Input/Handle.pm version: '1.810' MCE::Core::Input::Iterator: file: lib/MCE/Core/Input/Iterator.pm version: '1.810' MCE::Core::Input::Request: file: lib/MCE/Core/Input/Request.pm version: '1.810' MCE::Core::Input::Sequence: file: lib/MCE/Core/Input/Sequence.pm version: '1.810' MCE::Core::Manager: file: lib/MCE/Core/Manager.pm version: '1.810' MCE::Core::Validation: file: lib/MCE/Core/Validation.pm version: '1.810' MCE::Core::Worker: file: lib/MCE/Core/Worker.pm version: '1.810' MCE::Flow: file: lib/MCE/Flow.pm version: '1.810' MCE::Grep: file: lib/MCE/Grep.pm version: '1.810' MCE::Loop: file: lib/MCE/Loop.pm version: '1.810' MCE::Map: file: lib/MCE/Map.pm version: '1.810' MCE::Mutex: file: lib/MCE/Mutex.pm version: '1.810' MCE::Queue: file: lib/MCE/Queue.pm version: '1.810' MCE::Relay: file: lib/MCE/Relay.pm version: '1.810' MCE::Signal: file: lib/MCE/Signal.pm version: '1.810' MCE::Step: file: lib/MCE/Step.pm version: '1.810' MCE::Stream: file: lib/MCE/Stream.pm version: '1.810' MCE::Subs: file: lib/MCE/Subs.pm version: '1.810' MCE::Util: file: lib/MCE/Util.pm version: '1.810' requires: Carp: '0' Fcntl: '0' File::Path: '0' Getopt::Long: '0' IO::Handle: '0' Scalar::Util: '0' Socket: '0' Storable: '2.04' Symbol: '0' Time::HiRes: '0' base: '0' bytes: '0' constant: '0' perl: '5.008' strict: '0' warnings: '0' resources: bugtracker: https://github.com/marioroy/mce-perl/issues homepage: https://github.com/marioroy/mce-perl license: http://dev.perl.org/licenses/ repository: https://github.com/marioroy/mce-perl.git version: '1.810' MCE-1.810/MANIFEST0000644000175000017500000000213713006204541012256 0ustar mariomarioMakefile.PL Changes Copying Credits LICENSE MANIFEST MANIFEST.SKIP META.json META.yml README.md bin/mce_grep lib/MCE.pm lib/MCE.pod lib/MCE/Candy.pm lib/MCE/Core.pod lib/MCE/Core/Input/Generator.pm lib/MCE/Core/Input/Handle.pm lib/MCE/Core/Input/Iterator.pm lib/MCE/Core/Input/Request.pm lib/MCE/Core/Input/Sequence.pm lib/MCE/Core/Manager.pm lib/MCE/Core/Validation.pm lib/MCE/Core/Worker.pm lib/MCE/Examples.pod lib/MCE/Flow.pm lib/MCE/Grep.pm lib/MCE/Loop.pm lib/MCE/Map.pm lib/MCE/Mutex.pm lib/MCE/Queue.pm lib/MCE/Relay.pm lib/MCE/Signal.pm lib/MCE/Step.pm lib/MCE/Stream.pm lib/MCE/Subs.pm lib/MCE/Util.pm t/00_required_modules.t t/00_required_signals.t t/01_load_mce.t t/01_load_signal_arg.t t/01_load_signal_export.t t/01_load_signal_tag.t t/02_do_callback_args.t t/02_do_callback_result.t t/03_chunk_size.t t/03_user_args.t t/04_norm_que_local.t t/04_norm_que_manager.t t/04_norm_que_worker.t t/04_prio_que_local.t t/04_prio_que_manager.t t/04_prio_que_worker.t t/05_mce_flow.t t/05_mce_grep.t t/05_mce_loop.t t/05_mce_map.t t/05_mce_step.t t/05_mce_stream.t t/06_nodata_flow.t t/06_nodata_step.t t/06_relay.t MCE-1.810/Changes0000644000175000017500000014511313022712123012420 0ustar mariomario Revision history for Perl module MCE. 1.810 Fri Dec 09 23:30:00 EST 2016 * Updated check for IO handle allowed. This allows $gather_fh = *STDOUT{IO}, construction in Perl <= 5.10.1. Thank you, Qiang Wang. 1.809 Wed Nov 23 16:00:00 EST 2016 * Bug fixes for running MCE inside threads. * Random numbers are unique between workers. 1.808 Sat Nov 05 02:00:00 EST 2016 * Workers persist unless shutdown explicity while running alongside the Mojolicious framework. 1.807 Tue Nov 01 16:00:00 EST 2016 * Enhanced relay capabilities. Added Mandelbrot example to MCE::Example. Added extra demonstrations to MCE::Relay. Also, added test script. * Tweaked manager-loop delay for special cases -- applies to MSWin32 only. 1.806 Tue Oct 11 21:30:00 EST 2016 * Fixed two typos. Thank you, Florian Schlichting. * Support input_data with nested arrays in MCE Models. 1.805 Thu Sep 01 16:00:00 EST 2016 * Fixed bug in MCE::Queue (#4). Thank you, Mary Ehlers. * Improved support for running MCE with Tk. Added Tk demonstrations to MCE::Examples. Thank you, Götz Meyer. 1.804 Thu Jul 28 23:00:00 EST 2016 * Removed the sleep statement in MCE->restart_worker. * Added FCGI::ProcManager demonstrations to MCE::Examples. * Automatically set posix_exit to 1 whenever (F)CGI.pm is present. * Thank you Kai Wasserbäch (TheRealCuran) for the cool test case. https://github.com/marioroy/mce-perl/issues/1 1.803 Sun Jul 10 23:30:00 EST 2016 * Re-enabled Sereal 3.008+ for Perl < v5.12.0, if available. * Optimized dequeue methods in MCE::Queue. 1.802 Mon Jul 04 03:30:00 EST 2016 * Default to Storable for serialization in Perl less than v5.12.0. Sereal 3.008+, if available, is loaded automatically in Perl v5.12+. 1.801 Sun Jul 03 00:30:00 EST 2016 [BUG FIXES] * Fixed race condition in Queue->await. [ENHANCEMENTS] * MCE 1.801 is stable on all supported platforms. * Completed work supporting cyclical include of MCE Core / Models. * Updated MCE to support Perl included with Git Bash. * Renamed temp dir from 'mce' to 'Perl-MCE' under user's %TEMP% location on Windows. E.g. Native Perl, Cygwin, Git Bash. 1.800 Sat Jun 18 16:30:00 EST 2016 [BUG FIXES] * Fixed dequeue (count) in MCE::Queue for standalone mode. [ENHANCEMENTS] * On Windows, improved stablity and feature parity with UNIX. * Use Sereal 3.008+ automatically if available on the box. [NEW FEATURES] * Added support for cyclical include of MCE Core, MCE Models, and MCE Queue by scoping the configuration to the local package. This resolves (RT#107384), bug reported by Kai Wasserbäch. 1.708 Sat May 28 14:00:00 EST 2016 [BUG FIXES] * Improved import routine in MCE Models and MCE::Subs. This resolves an issue where functions are not exported; e.g. mce_flow, mce_flow_s. [ENHANCEMENTS] * Added support for IO::TieCombine handles. This enables MCE->print and MCE->sendto to work reliably with App::Cmd and App::Cmd::Tester. See Testing and Capturing Output in MCE::Examples. 1.707 Wed May 25 16:00:00 EST 2016 [BUG FIXES] * Fixed logic when workers exit. Improved reliability on Windows. [ENHANCEMENTS] * Applied MCE-1.700-provides.patch from RedHat. Thank you, Paul Howarth. * Added META.json to the distribution. 1.706 Fri Apr 22 21:30:00 EST 2016 [ENHANCEMENTS] * Time::HiRes sleep resolution is 15 milliseconds on Windows and Cygwin. Adjusted timeout values accordingly. Thank you, Daniel Dragan. * Reinstated the hack for faster IO when use_slurpio => 1 is specified. Tuned chunk_size => 'auto'. 1.705 Thu Apr 14 10:00:00 EST 2016 * Bumped version for Test::More to 0.88. Thank you, Paul Howarth. 1.704 Thu Apr 14 05:00:00 EST 2016 [BUG FIXES] * Fixed restart on the Windows platform, bug introduced in 1.700. * Reached *stable* on all major platforms for MCE 1.7x. [ENHANCEMENTS] * Enabled auto-destroy for MCE objects. * Enabled freeze callbacks for Sereal. * Switched bug tracking to Github. * Tweaked test scripts. 1.703 Sat Mar 19 23:00:00 EST 2016 * Completed IPC optimizations for 1.7. 1.702 Tue Mar 15 17:00:00 EST 2016 * Bumped version. 1.701 Tue Mar 15 12:00:00 EST 2016 [ENHANCEMENTS] * Some folks have expressed a wish for running MCE 1.7 with Perl v5.8. To restore support for Perl v5.8, removed MCE::Shared and MCE::Hobo from the MCE 1.701 distribution. * MCE::Shared will be released after MCE 1.700 is deleted from CPAN. Thank you for your patience during this transition. 1.700 Tue Mar 08 15:30:00 EST 2016 [BUG FIXES] * Fixed race condition on Windows for non-threaded workers. * Updated MCE Models to not fail when running inside an eval statement. This addresses (RT#105557) and (RT#105559). Thank you, Benjamin McKeown. * Added new MCE option loop_timeout to prevent the MCE Manager process from hanging perpetually. The manager process wrongly assumes a worker is still running when the worker died in an uncontrollable manner. This resolves (RT#111780). Thank you, Benjamin McKeown. [ENHANCEMENTS] * Perl 5.10.1 or later is required to run MCE 1.7. Perl < 5.10.1 lacks 'overloading.pm'. * Added code in MCE::Grep's documentation for parsing huge files. * Added support for running MCE with Perl under MobaXterm on Windows. * MCE/examples and MCE/images are no longer included with the distribution. These are maintained separately at https://github.com/marioroy/mce-examples and https://github.com/marioroy/mce-assets respectively. * MCE performs channel locking via a pipe or socket depending on platform. Previously, locking was through file locking using flock. This resolves the slow locking performance on Cygwin. * Optimized signal handling including improved support on Windows. * Reduced overhead during spawning and job submissions on Windows and Cygwin. This enables IPC to complete up to 20x faster, thus benefiting Monte-Carlo simulations; e.g. calling ->run(0) or ->process(...) repeatedly. * The MCE::Flow and MCE::Step Models can take an anonymous array for specifying use_threads uniquely for sub-tasks. [NEW FEATURES] * Added MCE::Hobo for running code asynchronously. This provides async/join functionality for processes similarly to async/join in threads. It includes ->is_joinable, ->is_running, ->join, ->kill, ->list, ->waitall, ->waitone, and other methods not metioned here. * Added MCE::Shared for sharing objects/data between threads/processes. * Added MCE::Shared::{ Array, Handle, Hash, Ordhash, and Scalar }. * Added MCE::Shared::{ Condvar, Minidb, Queue, and Sequence }. * Added MCE::Shared::{ Server }. * Added methods ->await, ->enq, and ->enqp to MCE::Step. * Added method ->await to MCE::Queue. * Added option max_retries => N for retrying a failed chunk from a worker dying while processing input data or sequence of numbers. * Added option posix_exit => 1 to avoid END and destructor processing. This is necessary for running with Tk and child processes or with use_threads => 0. * Seeds the Math::Random generator automatically when present for non-threads to avoid child processes sharing the same seed value as the parent and each other. The new seed is computed using the current seed. Thus, okay to set the seed at the application level for predictable results. 1.608 Fri Apr 10 03:00:00 EST 2015 * Correction for $prog_name (-e) to (perl) in MCE::Signal. 1.607 Fri Apr 10 01:00:00 EST 2015 [BUG FIXES] * Updated t/01_load_signal_arg.t to address false-positive from bug fix in 1.606. This was missed in the 1.606 release. Thank you Nigel Horne. [ENHANCEMENTS] * Replaced (-e) with (perl) for the $prog_name value in MCE::Signal; e.g. from running perl -e 'command'. 1.606 Wed Apr 08 18:00:00 EST 2015 [BUG FIXES] * Added -d and -w tests to ensure $ENV{TEMP} exists and writeable in MCE::Signal. Otherwise /tmp is used as usual. [ENHANCEMENTS] * Determine running state in MCE->exit. Call stop_and_exit if not already running to not hang the script. 1.605 Mon Apr 06 00:30:00 EST 2015 [BUG FIXES] * Improved fix for the die handler in MCE::Signal and MCE::Core::Worker. * Improved support for threads in MCE::Signal's stop_and_exit function. 1.604 Sat Mar 21 21:00:00 EST 2015 [BUG FIXES] * All bugs found during testing of the upcoming 1.7 release have been backported to the 1.6 branch. [NEW FEATURES] * Added out_iter_array and out_iter_fh to MCE::Candy. These preserve output order and cover the two general use cases. 1.603 Tue Mar 17 21:00:00 EST 2015 [ENHANCEMENTS] * A safer solution by Dmitry Karasik for the die handler in MCE::Signal and MCE::Core::Worker. * Moved ->forchunk, ->foreach, and ->forseq sugar methods to MCE::Candy. Stubs exist in MCE. Thus, no breakage to existing apps. * Removed the link to MCE::Shared on the main page. I decided to backport all the fixes into 1.6. The MCE::Shared link was missed and requires the upcoming 1.7 release. 1.602 Mon Mar 16 20:00:00 EST 2015 [BUG FIXES] * Updated die handler in MCE::Core::Worker and MCE::Signal (RT#102802) Bug reported by Dmitry Karasik. [ENHANCEMENTS] * MCE child processes call CORE::exit during exiting; previously CORE::kill. * Improved IPC stability on Windows and Cygwin. * Multiple calls to mutex->lock by the same process or thread is now safe. The mutex will remain locked until mutex->unlock is called. 1.601 Sun Mar 15 21:00:00 EST 2015 This release is attributed to the many use cases sent by George Bouras. [BUG FIXES] * Updated Makefile.PL allowing installation of bin/mce_grep (RT#102040). Running (MCE_INSTALL_TOOLS=1 perl Makefile.PL) installs bin/mce_grep. * Ensure MCE instances spawned by workers have shutdown before leaving. * An exiting forked non-MCE process will not cause the worker to exit. * Fixed sockets not closing immediately in Cygwin and Windows. * Fixed a pod error in MCE::Mutex. * Fixed a rare condition where socket handles for MCE::Mutex and MCE::Queue were closing pre-maturely when using threads. * Fixed an undefined variable inside croak statements in MCE Models' import subroutine. * Fixed automatic shutdown due to loading threads and specifying use_threads => 0 with workers persisting before exiting the script. [ENHANCEMENTS] * Moved relay methods, introduced in 1.600, from MCE to MCE::Relay. The MCE init_relay option loads and enables MCE::Relay automatically. * Captured metrics from Linux (previously OS X) for forchunk.pl, foreach.pl, and forseq.pl. Updated Examples.pod. * Default to 'auto' for max_workers in bin/mce_grep, examples/egrep.pl, forchunk.pl, foreach.pl, forseq.pl, iterator.pl, and wc.pl. * Moved _create_socket_pair from MCE to MCE::Util as _make_socket_pair. Added _destroy_sockets. Updated MCE, Mutex, and Queue to use MCE::Util. * Added a CARP_NOT line to MCE Models. * Added support for ->next and ->last from any sub-tasks in MCE::Step. * Reverted a small change applied in 1.600 to ->do and ->gather. * The 'synchronize' method in Mutex is wantarray aware. * Updated POD header lines for method names; from =item to =head2. * Workers now set STDERR and STDOUT to flush automatically. [NEW FEATURES] * Added ->pid method to MCE. 1.600 Sat Jan 31 20:00:00 EST 2015 [BUG FIXES] * Die handlers (in MCE::Signal and MCE::Core::Worker) are finally 100%. Furthermore, eval { die ... } statements behave correctly while running MCE itself inside an eval block. Thus, MCE on iPerl on top of iPython is possible via Devel::IPerl. * Fixed queues stalling from running (MCE::Queue fast => 1) on Linux. * MCE Models now set $MCE::FREEZE, $MCE::THAW, and $MCE::TMP_DIR when overriding freeze, thaw, and tmp_dir respectively at load time. * Pressing CTRL-D now ends STDIN the first time. [ENHANCEMENTS] * Added seven names to CREDITS; David Farrell, Demian Riccardi, Hisham Eldai, Joel Berger, Oleksandr Kharchenko, Wei Shen, and Zakariyya Mughal. * Refactored ->print, ->printf, and ->say. Optimized ->print some more. * Shorten $_queue to $_Q in Queue. ID is always sent first during IPC. * The init method in MCE Models can now take an array of options. * Optimized memory consumption in Handle.pm, Iterator.pm, and Request.pm. * Optimized memory consumption for ->sendto, ->do, and ->gather. * Optimized memory consumption for overall IPC in general. * Refreshed the MCE->new method. [NEW FEATURES] * Added a new module; MCE::Mutex providing simple semaphore. * Added ->relay_recv, ->relay, and ->relay_final methods to the Core API. Refreshed cat.pl and findnull.pl examples to relay the number of lines read. Workers output exclusively and orderly to STDOUT in cat.pl. * Added several examples; biofasta (folder), mutex.pl, and relay.pl. The FASTA examples process by records "\n>", not by lines. * MCE applies additional logic when RS begins with a newline character; e.g. RS => "\n>". It trims away characters after the newline and prepends them to the next record. This happens automatically when not slurping. Otherwise, the logic is applied to the first and last records only. This is illustrated in the Core API documentation. * Updated the Core API documentation (RS, added relay methods). 1.522 Thu Dec 25 16:00:00 EST 2014 [BUG FIXES] * Applied fix to MCE->shutdown so that MCE Models do not err when receiving signal to terminate. * Optimization for MCE->print, MCE->printf, MCE->say and MCE->sendto. This was calling fileno unnecessarily. MCE->print('STDERR', ...) is not supported. This works; MCE->print(\*STDERR, ...) [ENHANCEMENTS] * Inserts the actual lib-path at the head of @INC in example files. * Massive documentation updates throughout the entire distribution. * Renamed barrier_sync.pl to sync.pl; scaling_pings.pl to ping.pl. * Updated requires in META.yml, Makefile.PL and perl-MCE.spec. * Updated comment in MCE::Queue test scripts. * Updated the README file. [NEW FEATURES] * Added sampledb examples demonstrating DBI and SQLite with MCE. * Added step_demo.pl to examples. 1.521 Thu Dec 11 16:00:00 EST 2014 [BUG FIXES] * Fixed broken MCE::Queue ->insert and ->peek methods. FIFO and LIFO are fully supported with this release. * Support running in taint mode. [ENHANCEMENTS] * Added support for negative index in MCE::Queue ->insert and ->peek. Updated the documentation. * CBOR::XS serialization is mentioned in documentation along with JSON::XS and Sereal. * Completed code refactoring for the 1.5 branch. * Optimized argument parsing in import routines. * Removed the MCE spawn_delay option from test scripts. [NEW FEATURES] * Added 15 new test scripts for testing user_args, MCE::Queue and the MCE Models. * An upper-limit of 8 is set when specifying max_workers => 'auto'. Several folks have requested this. More info at MCE::Util::get_ncpu for increasing or decreasing the limit. 1.520 Wed Nov 05 03:00:00 EST 2014 [ENHANCEMENTS] * MCE::Step and MCE::Stream can take the 'fast' option when including the module. The 'fast' option was introduced in 1.518. * Removed the type declaration for self (feedback from Sri). * Removed -s from files_flow.pl (was left behind). * Added support for GNU Hurd OS in get_ncpu. 1.519 Mon Oct 27 19:00:00 EST 2014 [ENHANCEMENTS] * Unset the need for channel locking if only worker riding the channel. There are 8 data channels in MCE. Basically, a worker will obtain a lock only when sharing the data channel with another worker. * Updated files_flow.pl, files_mce.pl and files_thr.pl to allow for many workers for the first task. Updated the synopsis in MCE::Queue. Synced example listing in Examples.pod with the examples folder. * Remove period from summary line. 1.518 Mon Oct 27 10:00:00 EST 2014 [BUG FIXES] * Corrected MCE::Queue's synopsis due to missing List::MoreUtils line. Changed the synopsis to use 1 worker for the 'dir' task in the event one were to copy/patse the code and use threads. The glob() function is not thread-safe in Perl 5.16.x; fixed in 5.18.2, okay in 5.8 - 14. * Use portable syntax for setpgrp in MCE::Signal. This closes issue 1 at https://code.google.com/p/many-core-engine-perl. [NEW FEATURES] * New 'fast' option for MCE::Queue. The 'fast' option speeds up ->dequeue ops and not enabled by default. It is beneficial for queues not needing ->clear or ->dequeue_nb and not altering the optional count value while running; e.g. ->dequeue( [ $count ] ). * Added three examples: files_flow.pl, files_mce.pl, and files_thr.pl. * Benchmarked on several OSes and appended results to MCE::Queue synopsis. 1.517 Thu Oct 23 10:00:00 EST 2014 [BUG FIXES] * Correction applied to MCE::Util::get_ncpu for Tru64 UNIX. This method will emit a warning (not croak) whenever the OS is unknown. * Changed ${^CHILD_ERROR_NATIVE} to $? in examples/pipe2.pl. This was missed in the previous release. [ENHANCEMENTS] * Added support for DragonFly BSD, SCO OpenServer 5, SCO OpenServer 6 and SCO UnixWare 7 to MCE::Util::get_ncpu. * Also, validated MCE on FreeBSD, NetBSD, OpenBSD, PC-BSD and JabirOS. No further changes to MCE::Util::get_ncpu. 1.516 Fri Oct 03 02:00:00 EST 2014 [BUG FIXES] * Updated IPC for better stability across multiple environments. The fix addresses an issue on Windows where sockets fail to respond after a period of inactivity; i.e. 4 minutes. Added George Bouras to CREDITS for reporting the issue. * Tip for folks developing on Windows: Open an explorer window and go to C:\Users\\AppData\Local\Temp. Right-click on the 'mce' folder and create a shortcut on the desktop. Although MCE removes its temp files automatically, it is possible for files to remain from a failing app. Go inside the 'mce' folder and press ctrl-a to select all files. Then press shift-delete; (macbook[pro] folks: fn-shift-delete). [ENHANCEMENTS] * Corrections to documentation. 1.515 Thu Jul 24 23:30:00 EST 2014 [BUG FIXES] * bin/mce_grep: ${^CHILD_ERROR_NATIVE} is not defined in Perl 5.8.x. Changed to $?. [ENHANCEMENTS] * Tweaked bin/mce_grep. Compute chunk_level => 'auto' to use 'file' when reading STDIN. Set chunk_size to 8M when not specified (4M previously). * Added the following names to CREDITS. Stephan Kulow ; for making the OpenSUSE MCE package Henry Lu ; for listening while I chatted away about MCE Jillian Rowe ; for reporting IO::File failing as input_data Sylvia Roy ; for driving while I worked in the passenger seat Tom Sasser ; for reporting bin/mce_grep failing with Perl 5.8.x Florian Schlichting ; for making the Debian MCE package [NEW FEATURES] * Added support for IO::File handles as valid input_data including IO:Uncompress:Gunzip. Modified SYNTAX section for INPUT_DATA in MCE::Core.pod. input_data => $fh, ## new IO::File "file", "r" input_data => $fh, ## new IO::Uncompress::Gunzip "file.gz" 1.514 Thu Jun 05 09:00:00 EST 2014 [BUG FIXES] * Fixed typo in MCE::Step POD (RT#95250) (Florian Schlichting). * Updated MCE::Util's get_ncpu function for AIX (Dana Jacobsen). * Do not send a KILL signal after receiving a SIGPIPE. * Fixed issue with Makefile.PL on defining the minimum Perl version. * Use Scalar::Util (looks_like_number) for validation logic. The regex previously were insufficient for large numbers containing scientific notation. This impacted the sequence option in MCE. [ENHANCEMENTS] * The mce-sandbox demo has been released on Github demonstrating Perl + MCE + Inline::C. The theme is Prime Numbers. This journey which began 2 years ago has been completed. There is also the mce-sort exercise demonstrating Perl + MCE + External C. https://github.com/marioroy/mce-sandbox (is thread-safe) https://github.com/marioroy/mce-sort (not thread-safe) * A hard decision had to made for MCE, particularly Perl under Windows excluding Cygwin. MCE will now load the 'threads' module automatically for Windows only. Folks may specify use_threads => 0 if threads is not desired. The reason for this is from seeing Math::Prime::Util crashing once workers exit. The same is true without MCE and forking a child process. Threads does not exhibit this behavior. It is a hard problem to solve. Why not default to threads for Windows since forking is emulated. 1.513 Sat Apr 19 20:30:00 EST 2014 [BUG FIXES] * Added fix for bug RT#94869 -- crash when restarting workers with 9+ workers. Updated the perldoc for restart_worker in MCE::Core.pod. [ENHANCEMENTS] * Replaced $self with $mce in MCE::/Core.pod to be consistent with examples described in MCE::Examples.pod. 1.512 Fri Apr 18 21:00:00 EST 2014 [BUG FIXES] * Signal-handling update for MCE::Signal. Passing the -setpgrp option is not necessary, even with Daemon::Control. Piping data into and out is better supported with this release (\*STDIN). This resolves bug RT#94706. cat infile | mce_script | head mce_script < infile | head Added Shawn Halpenny to the CREDITS file. * The utf8.pl example now runs under the BSD 9.0 environment. This was failing due to $^H{charnames} is not defined error. Removed the constant from the list of unicode characters inside the script. [ENHANCEMENTS] * Added examples/pipe1.pl and pipe2.pl. These process STDIN or FILE in parallel. Processing is via Perl for pipe1.pl, whereas an external command for pipe2.pl. 1.511 Fri Apr 04 22:30:00 EST 2014 [BUG FIXES] * Added "use bytes;" in several files to have length() return physical bytes, not logical characters. MCE is now UTF-8 safe when passing scalar data between workers and the manager process. Added Marcus Smith to the CREDITS file for reporting this bug. [ENHANCEMENTS] * Added examples/utf8.pl 1.510 Thu Mar 27 10:00:00 EST 2014 [ENHANCEMENTS] * The user_begin and user_end functions now receive 3 arguments. my ($mce, $task_id, $task_name) = @_; * Pass the chunk_size value when calling the iterator function. Added a DBI example under "SYNTAX for INPUT_DATA" in MCE::Core.pod. * Store the last scalar reference to not have workers re-spawn unnecessarily when input_data => \$same_scalar_ref. [NEW FEATURES] * New parallel_io option to further enhance slurp IO when specifying use_slurpio => 1 and chunk_size is greater than 8192. Try with chunk_size => '300k' or chunk_size => '2m'. The parallel_io option is beneficial when reading from fast storage. However, possibly not recommended if running MCE on many compute nodes and having workers read various input_data from shared storage. Enable parallel_io only if it makes sence and without impacting the environment such as nfsd. Because use_slurpio => 1, parallel_io => 1, and chunk_size => '2560k' is truly parallel. 1.509 Sat Feb 03 05:30:00 EST 2014 [BUG FIXES] * Fixed an issue with all the models (Flow, Grep, Loop, Map, Step, and Stream) ending immediately on subsequent runs when input_data is specified through the init method. * Things have finally settled down with all the models. [ENHANCEMENTS] * Refactored the fix applied in 1.508 for addressing bug #92627. * MCE, for the most part, has been completed. This release touches up on many examples under the 'examples' directory. * Brought the MCE::Examples Perl documentation up to date. Inlined MCE::Loop snippets under the chunking sections. Added a new section GLOBALLY SCOPED VARIABLES AND MCE MODELS. Added a new section MONTE CARLO SIMULATION. 1.508 Sat Feb 01 04:00:00 EST 2014 [BUG FIXES] * Applied fix for bug #92627 submitted by Philip Mabon. MCE scripts may exit with a non zero error code due to leaving workers up thereby having MCE performing the shut down in its END block. For folks running on an older release, the workaround is to shut down workers prior to exiting. 1.507 Fri Jan 30 23:00:00 EST 2014 [ENHANCEMENTS] * Added clarity around preserving output order for several Models; MCE::Flow, MCE::Loop, and MCE::Step. * Inlined comments in the code for overriding MCE options when using an anonymous hash for the first argument; MCE::Flow, MCE::Step, and MCE::Stream. * Removed unnecessary code due to one not able to pass MCE options other than through the init method for MCE::Loop, MCE::Grep, and MCE::Map. * Added to doc a use-case example searching a large file with mce_grep_f. The emphasis is comparing the memory consumption against the native grep function as well as time to complete. 1.506 Fri Jan 30 03:00:00 EST 2014 [BUG FIXES] * Fixed issue with all 5 models croaking for an internal '_file' option. This has been broken since the 1.502 release. Methods impacted were: mce_flow_f, mce_grep_f, mce_loop_f, mce_map_f, and mce_stream_f * Specifying a different value for gather on subsequent runs is now taking effect for when workers persist after running. The models impacted are MCE::Flow and MCE::Loop. * Updated _parse_chunk_size in MCE::Util to compute chunk_size correctly for new edge cases. One may call either mce_grep or mce_grep_f for a GLOB or scalar reference as input data. The same also applies for the other models; mce_flow, mce_loop, mce_map and mce_stream. [ENHANCEMENTS] * Updates to MCE::Grep and MCE::Map. The logic is now aware of wantarray for faster processing when storing to a scalar value. In addition, the use_slurpio option is enabled for efficient IO when processing large files. * The task_end option can now be specified for MCE::Stream, although being used internally. * The interval option can take a decimal number. Previously, this wanted a hash reference with up to 3 key/value pairs. Most often, all one needed was delay and not max_nodes or node_id. interval => { delay => 0.05 } ## Choose either format for specifying interval => 0.05 ## delay in 1.506 and above. MCE will ## translate 0.05 to { delay => 0.05 } ## automatically. * Slight optimization to get_ncpu (public method) in MCE::Util. * Tweak to _parse_chunk_size (private method) in MCE::Util. [NEW FEATURES] * Added a new model MCE::Step for transparent use of MCE::Queue when passing data among sub-tasks. MCE::Step is basically a spin off from MCE::Flow with a touch of MCE::Stream. This new model is crazy :) 1.505 Thu Jan 21 01:30:00 EST 2014 [BUG FIXES] * Delete $self->{input_data} inside the worker immediately during spawning (if input_data is an ARRAY, GLOB, or Iterator reference). * Reverted the logic for the RS (record separator) option from the 1.4x code base. This is now working as expected. * Specifying chunk_size => 'auto' via the 'init' method (all 5 models) causes MCE validation to croak due to 'auto' being carried over to the core API. Note that only the 5 models are allowed 'auto' for chunk_size as of this time. * Update to the MCE->do method. Previously, an undef sent back from the callback function ended up as a blank value "". Both "" and undef are now properly captured and sent back to the worker process. * Added an if statement inside the 'abort' method. * Removed an old unlink _store.db statement (old code left behind). * Removed an unused _next variable inside Request.pm. [ENHANCEMENTS] * Enhanced egrep.pl to handle additional options including recursion. This script now supports many egrep options [ceHhiLlmnqRrsv]. * IO performance for examples/cat.pl was improved. The real focus here is demonstrating output order. * The chunk_size option can take a suffix; K (Kilobytes) or M (Megabytes). * The following examples except --max-workers=NUM --chunk-size=NUM options. cat.pl, egrep.pl, findnull.pl, scaling_pings.pl, and wc.pl [NEW FEATURES] * The input_data option can now receive an iterator reference. Added a new example iterator.pl for demonstraton. In addition, there are several examples listed under a new section "SYNTAX for INPUT_DATA" under MCE::Core.pod. * Added a new demo script; bin/mce_grep. This is a wrapper script for the grep binary. This script supports agrep, grep, egrep, fgrep, & tre-agrep. Simply create a link to mce_grep or make a copy. Both Windows and Cygwin are supported as well. Recursion works for all binaries including agrep (-R, -r options). ln mce_grep mce_agrep ln mce_grep mce_egrep ln mce_grep mce_fgrep ln mce_grep mce_tre-agrep Try with the --lang=C option for faster execution time (-i runs faster). Try mce_agrep or mce_tre-agrep against very large files. The speedup is linear and makes good utilization of all available cores on the box. One may specify the chunking level via the --chunk-level option. For large files, specify 'file' (chunks file). For many small files, use 'list'. I have tested against the following GnuWin32 packages found at this URL. http://gnuwin32.sourceforge.net/packages.html tre-0.7.5-bin.zip ## Contains agrep.exe (also runs under Cygwin) grep-2.5.4-bin.zip ## Contains egrep.exe, fgrep.exe, grep.exe libiconv-1.9.2-1-bin.zip ## These are required for the GnuWin32 binaries. libintl-0.14.4-bin.zip pcre-7.0-bin.zip regex-2.7-bin.zip Btw, bin/mce_grep is optional and therefore not installed by default when running make install for the MCE module. Simply copy mce_grep as mce_agrep.pl for Windows. The '.pl' suffix is optional for other environments. 1.504 Tue Oct 29 16:00:00 EST 2013 [BUG FIXES] * MCE::Grep, MCE::Map, and MCE::Stream were failing for mce_grep_s, mce_map_s, and mce_stream_s when specifying chunk_size => 1. [ENHANCEMENTS] * Calibrated 'auto' slightly in MCE::Util::_parse_chunk_size. 1.503 Mon Oct 28 17:00:00 EST 2013 [BUG FIXES] * The previous release introduced a bug by removing the line closing STDERR and STDOUT prior to workers exiting. The proper fix intended is to flush (not close) the handles. Closing them was not the thing to do in the first place due to possibly needed by the END block or WARN/DIE handlers initiated from inside the END block. [ENHANCEMENTS] * Updated README under examples/tbray and examples/matmult. * Changed 0.499 to 0.5 inside the yield method. * Small cosmetic changes otherwise. 1.502 Mon Oct 21 16:00:00 EST 2013 [BUG FIXES] * The END block for all models will return immediately when called by a worker thread or process. Removed the line closing STDERR and STDOUT prior to workers exiting. It turns out that workers were calling shutdown which is not allowed. This impacted MCE::Flow, MCE::Grep, MCE::Loop, MCE::Map, and MCE::Stream. * An update was applied to DESTROY in MCE::Queue to address an edge case during additional testing across several environments. * Added documentation describing the core methods in MCE. I had moved the missing sections to another file some time back and totally forgotten about them when finalizing on MCE::Core.pod for the 1.5 release. [ENHANCEMENTS] * All models will croak when specifying an invalid MCE option. [NEW FEATURES] * One can specify a hash reference for the gather option. Updated documentation describing the gather option and the gather method. 1.501 Wed Oct 16 01:20:00 EST 2013 [BUG FIXES] * Addressed an issue with the worker signal "die" handler (#89538). Eval'd code should not raise an exception causing the app to die. This is working as expected for workers spawned as children. For threads, a die called explicitly inside an eval block will cause the worker to exit (same as previously). However, an eval 'use MissingModule' will no longer cause the thread to die. [ENHANCEMENTS] * Changelog section uses a new format beginning with this release. [NEW FEATURES] * Added examples/flow_model.pl for demonstrating MCE::Flow, MCE::Queue, and MCE->gather. 1.500 Thu Oct 10 01:00:00 EST 2013 * MCE 1.5 is backwards compatible with 1.4 and below. * The documentation, previously MCE.pod, moved to MCE::Core.pod with the examples section placed in MCE::Examples.pod. The MCE.pod file serves as an index page for the various documentation. * IPC has been enhanced with 8 data channels. Many operations run 3x when compared with MCE 1.4. * Five models: MCE::Flow, MCE::Grep, MCE::Loop, MCE::Map, and MCE::Stream. * Hybrid queues via MCE::Queue allowing for normal and priority queues. * MCE::Subs for exporting functions prefixed with mce_; e.g. mce_wid. * All public methods can be called directly using the package name and method e.g. MCE->wid, MCE->run. MCE->new( max_workers => 'auto', user_func => sub { my $wid = MCE->wid; MCE->sendto("STDOUT", "Hello from $wid\n"); } ); MCE->run; * Localize the input scalar $_ prior to calling user_func. Folks can use $_ for input_data and sequence of numbers. Added section to docs explaining DEFAULT INPUT SCALAR. * New options (bounds_only, gather, interval, task_name). The task_end option can now be specified at the top level. See docs for use case. Input_data can be specified inside the first task instead of having to specify this at the top level. Input_data is ignored when specified for tasks other than the first task. user_tasks => [{ input_data => \@list, ... },{ ... } * New public methods chunk_id, gather, freeze, thaw, yield, task_name, print, printf, say * New example (interval.pl). * Optimized the egrep.pl and wc.pl examples. These run much faster. Try these out against large log files. Both examples fly. * Barrier synchronization update. Two sockets are utilized instead of 2 lock files. This, now works wonderfully under the Cygwin environment. For threading, the removal of 2 lock files increases the number of threads allowed from about 1/3rd previously to under 1/2 of ulimit, e.g. int(ulimit -n / 2 - 20). * Removed the logic for determining MAX_OPEN_FILES and MAX_USER_PROCS. MCE no longer has a constraint on max_workers allowed. * Code re-factor work. Added a private method _validate_runstate called by various methods. Organized the code slightly such as placement of methods. 1.415 Mon Jun 17 15:00:00 EST 2013 * Code-refactor in preparation for the upcoming 1.5 release. This completes the 1.4x branch for a very solid and stable release. * IPC optimization. Localize $\ and $/ only as needed. Small tweak to logic when specifying RS (record separator) for input data. Foreach is very communication intensive. Forseq is less so. Chunking was made faster by increasing chunk size from 500 to 2500. I've reached my goal for forseq by reaching 60,000+. A while back, foreach could barely reach 18,000. Before and after results with IPC optimization. (Before) (After) Parallel::Loops 600 600 $mce->foreach 20,000 21,500 (+ 1,500) $mce->forseq 55,000 64,000 (+ 9,000) $mce->forchunk 395,000 450,000 (+ 55,000) * Updated the process method. Allows sequence to be specified as an option. Also allow the hash to be specified as the 1st or 2nd argument. $mce->process( \@input_array, { options } ); $mce->process( { options }, [ 1..1000 ] ); $mce->process( { sequence => [ 20, 40, 2 ] } ); * The forseq method will now honor chunk_size greater than 1. Updated docs with use case. * Added CONST short for EXPORT_CONST, e.g. use MCE CONST => 1; 1.414 Sun Jun 16 13:00:00 EST 2013 * Upstream bug fixes. Mainly chunk_size was not honored when specifying user_tasks and sequence/chunk_size for the first task. Bug is with not setting abort_msg correctly. 1.413 Mon Jun 10 02:00:00 EST 2013 * Fixed typo: Changed local @_ to local $@ inside _parse_max_workers before evaling. 1.412 Sun Jun 09 14:00:00 EST 2013 * Updated the main README file and CHANGES under 1.411 below. * Added support for multiplication and division as well as case insentivity to the private _parse_max_workers method. max_workers => 'auto', ## = MCE::Util::get_ncpu() max_workers => 'Auto-1', ## = MCE::Util::get_ncpu() - 1 max_workers => 'AUTO + 3', ## = MCE::Util::get_ncpu() + 3 max_workers => 'AUTO * 1.5', max_workers => 'auto / 1.333', 1.411 Sun Jun 09 02:00:00 EST 2013 * Reverted the change made in MCE-1.410. That degraded slurp IO on large files. This restores slurp IO performance in MCE. * Corrected an if statement towards the end of the shutdown method. The delay was occurring always when it was meant only if MCE was launched from inside a non-main thread. * Addressed a race condition with barrier synchronization under the Cygwin environment. Was not able to reproduce this with other OS's. This takes barrier synchronization work to 100%. Delay statements for Cygwin were removed around barrier synchronization. * Optimized writes to sockets. Arguments passed to print statements are concatenated as one big string. Removed local $/ = $LF when reading from the queue socket. It's not required there since using read and known size. The foreach.pl example (very communication intensive) can now do 20000 in 1 second on my Macbook Pro. Updated benchmark results inside foreach.pl, forchunk.pl, and forseq.pl. * MAX_WORKERS, CHUNK_SIZE, TMP_DIR, FREEZE and THAW can be specified when loading the module. FREEZE and THAW allows one to choose an alternative serialization module if preferred for your project. use Sereal qw(encode_sereal decode_sereal); use MCE FREEZE => \&encode_sereal, THAW => \&decode_sereal; * Passing EXPORT_CONST => 1 will export 3 constants: SELF, CHUNK, CID The "my ($self, $chunk_ref, $chunk_id) = @_" line is not necessary. $_[SELF], $_[CHUNK], $_[CID] refers to $_[0], $_[1], $_[2]. * The MCE::Util module was created. It contains the get_ncpu function. This is largely borrowed from Test::Smoke::Util.pm. MCE supports 'auto' when specifying max_workers. Read doc for other use case. max_workers => 'auto'; ## Same as MCE::Util::get_ncpu() * Re-factored code in preparation for the upcoming 1.5 release. The 1.5 release will use just 3 socket pairs versus 4. I did not want to include that change in this release. Therefore, I decided to take the upstream bug fixes and apply them to the 1.4 base. Re-factored documentation by making use of the full 78 character width per line. * Updated the main README file under the top level dir. 1.410 Tue May 28 23:30:00 EST 2013 * Use threads under MSWin32 for 02* and 03* test scripts. * Removed sysopen/sysseek/sysread to simplify logic due to negligible performance gains over open/seek/read. * Minor updates to documentation. 1.409 Sun May 12 22:45:00 EST 2013 * Croak if user_func is not defined and input_data/sequence is specified. * Fix barrier synchronization when running multiple tasks via user_tasks. * Updated Perl documentation for easier reading through cpan/metapan. * Renamed private method _worker_sequence to _worker_sequence_queue. 1.408 Tue Mar 19 22:00:00 EST 2013 * Minor tweaks here and there to further increase reliability. * Updated the barrier synchronization logic to not stall. Updated the perl docs on mixing "sync" with "do" or "sendto" methods. * Added new "status" method for the manager process. * Added new arguments for MCE::Signal: -no_kill9, -no_sigmsg 1.407 Thu Mar 14 21:00:00 EST 2013 * This marks a tremendous effort in achieving parity across the board from Cygwin to Windows and obviously UNIX. MCE now works beautifully under the Cygwin environment including Perl for Windows. * Up'ed the maximum workers allowed for both Cygwin and Windows to 56 (forking) and 80 (threading). * Barrier synchronization requires an extra semaphore file, therefore the maximum workers allowed under the UNIX environment for threading decreased. It shouldn't be a problem as there are many threads already. * Addressed an issue with barrier synchronization under Cygwin. * Addressed an issue with the die handler for the main worker method when threading. * Thank you for hanging in there. It took quite some time to get there. This is the most stable release thus far for MCE across the board. 1.406 Tue Mar 12 19:00:00 EST 2013 * Added support for barrier synchronization (via new sync method). Added barrier_sync.pl example. * Addressed rounding errors with the sequence generator. The sequence option now follows a bank-teller queuing model when generating numbers. This applies to task 0 only. Other tasks can still specify sequence where numbers will be distributed equally among workers like before. * Optimized the _worker_request_chunk private method. * A take 2 on the matrix multiplication examples. This is better organized with updated README file to include the script running time in the results. 1.405 Mon Mar 04 19:00:00 EST 2013 * Added strassen_pdl_t.pl in the event folks cannot make use of /dev/shm used by the strassen_pdl_s.pl example. * Optimized the 'send' method -- workers process immediately after receiving data. Updated run times in README for the strassen examples. * MCE no longer calls setpgrp by default as of MCE 1.405. There is only one reason to call setpgrp, but many reasons not to. The sole reason was for MCE to run correctly with Daemon::Control. If needed, one can pass the option to MCE::Signal qw(-setpgrp). * Return void in the shutdown method (previously was returning $self). * Tidy code inside sequence generator. 1.404 Sun Feb 24 13:00:00 EST 2013 * Added sess_dir method * Completed work with matmult/* examples Added matmult_pdl_q.pl, removed strassen_pdl_h.pl Added strassen_pdl_o/p/q/r/s.pl Added benchmark results from a 32-way box at the end of the readme * Removed lines setting max limit for files/procs 1.403 Sun Feb 17 15:00:00 EST 2013 * Wrap sub PDL::CLONE_SKIP into a no warnings 'redefine' block MCE now works with PDL::Parallel::threads without any warnings * Added missing examples/matmult/matmult_pdl_n.pl to MANIFEST * Refactored strassen examples, memory consumption reduced by > than 50% * Added matmult_pdl_o.pl -- uses PDL::Parallel::threads to share matrices * Added matmult_pdl_p.pl -- matrix b is read from shared memory, not mmap * Added strassen_pdl_n.pl -- additional improvements to memory reduction * Added strassen_pdl_h.pl -- shown running with 4 workers (half and half) * Re-ran matrix multiplication examples and updated results in README file * Added -no_setpgrp option to MCE::Signal.pm Ctrl-C does not respond when running /usr/bin/time mce_script.pl * Added undef $buffer in a couple of places within MCE.pm * Added David Mertens and Adam Sjøgren to CREDITS * The 'send' method now checks if sending > total workers after spawning not before 1.402 Thu Feb 14 07:30:00 EST 2013 * Updated matrix multiplication examples including README * Added examples/matmult/matmult_pdl_n.pl 1.401 Tue Feb 12 19:00:00 EST 2013 * Added sub PDL::CLONE_SKIP { 1 } to MCE.pm. Running PDL + MCE threads no longer crashes during exiting. * Updated matrix multiplication examples. All examples now work under the Windows environment no matter if threading or forking. Unix is stable as well if wanting to use PDL + MCE and use_threads => 1 or 0. * Added benchmark results for 2048x2048, 4096x4096, and 8192x8192 to the README file under examples/matmult/ * Updated documentation 1.400 Mon Feb 11 07:00:00 EST 2013 * Slight optimization in the _do_callback method * Added 2 new options: user_args and RS (record separator) * Added new send method for sending data to workers after spawning and prior to running * The sequence option can now take an ARRAY reference * Updated documentation on new features * Added matrix multiplication examples 1.306 Sat Jan 05 18:00:00 EST 2013 * Added if statement around setpgrp(0,0). That function is not supported under Windows. * Updated logic for removing any remaining MCE session directories inside MCE::Signal. 1.305 Sat Jan 05 16:00:00 EST 2013 * Added check for $^S to the DIE handler inside the _worker_main method * Added setpgrp(0,0) to MCE::Signal's BEGIN block * MCE::Signal points to a _mce_sess_dir hash in the event of a signal, will remove the sess_dir(s) as well. This is needed when tmp_dir is specified during instantiation and pointing to another location than MCE::Signal::tmp_dir. 1.304 Wed Jan 02 22:00:00 EST 2013 * Added Oliver Gorwits to CREDITS for identifying 2 issues * Direct die to CORE::die inside handler if executing an eval * Undef $mce_spawned_ref if signal was caught (stop_and_exit) * Changed INIT to sub import in MCE.pm 1.303 Tue Jan 01 20:00:00 EST 2013 * Bump version -- MCE.pm VERSION now matches with META.yml * Sorted forchunk, foreach, forseq methods inside MCE.pm * Modified if statement in run method * Task ID is never undef, therefore removed check inside restart_worker and worker_do methods * Added 2 package variables to MCE::Signal $display_die_with_localtime and $display_warn_with_localtime * Completed updates to documentation * Update to forseq.pl and seq_demo.pl examples 1.302 Tue Jan 01 07:30:00 EST 2013 * Fixed validation logic for sequence * Updated the sequence generator -- now supports chunking * Updated seq_demo.pl example to demo user_tasks, sequence, and chunk_size applied together * Documentation updates 1.301 Mon Dec 31 15:00:00 EST 2012 * Emphasis on documentation -- better flow plus additional clarity * Minor updates to sequence option validation * Minor updates to included examples 1.300 Mon Dec 31 06:00:00 EST 2012 * New methods...: chunk_size, restart_worker, task_id, task_wid, tmp_dir * New options...: on_post_exit, on_post_run, sequence * New examples..: forseq.pl, seq_demo.pl * Overhaul to exit method Workers can exit or die without impacting the manager process * Enabled executable bit for test files * Removed localtime output in die and warn handlers * All 3 delay options are consistent whether user_tasks is specified * Removed logic around total_ended count -- replaced with new exit logic * Code refactoring plus documentation updates * Added LICENSE file 1.201 Fri Dec 21 00:00:00 EST 2012 * Added MCE.pod -- moved documentation from MCE.pm to pod file * Added missing use strict/warnings to test scripts * Default to 1 for chunk_size and max_workers if not specified * Test::More is not a requirement to run MCE, only for building * Changed the format for the change log file 1.200 Thu Dec 20 00:00:00 EST 2012 * Added new user_tasks option * Added space between method name and left-paren for header lines in POD * Remove not-needed BSD::Resource and forks inside BEGIN/INIT blocks 1.106 Wed Dec 19 05:00:00 EST 2012 * Added t/pod-coverage.t * Big overhaul of the MCE documentation -- all methods are documented * Croak if method suited for a MCE worker is called by the main MCE process * Croak if method suited for the main MCE process is called by a MCE worker * Updated Makefile.PL to declare the minimum Perl version 1.105 Sun Dec 16 23:00:00 EST 2012 * Completed code re-factoring * Added t/pod.t 1.104 Sun Nov 25 17:00:00 EST 2012 * Added 1 new example to MCE's Perl documentation * Use module::method name versus constant symbol when calling _croak * Croak if session directory is not writeable inside MCE::spawn * Renamed _mce_id to _mce_sid (meant to be spawn id actually) * Re-calibrated maximum workers allowed 1.103 Fri Nov 23 13:00:00 EST 2012 * Added writeable check on /dev/shm * Croak if tmp dir is not writeable inside MCE::Signal::import 1.102 Thu Nov 22 13:00:00 EST 2012 * Woohoot !!! MCE now passes with Perl 5.17.x * Added Copying file -- same as in Perl 1.101 Wed Nov 21 16:00:00 EST 2012 * Shifted white space to the left for code blocks inside documentation 1.100 Wed Nov 21 10:00:00 EST 2012 * Completed optimization and shakeout for MCE's existing API * File handles are cached when calling sendto and appending to a file * The sendto method now supports multiple arguments -- see perldoc * Added new option: flush_file 1.008 Sat Nov 17 23:00:00 EST 2012 * Updates to __DIE__ and __WARN__ handling in MCE. These address the unreferenced scalars seen in packaging logs at activestate.com for Perl under Windows: http://code.activestate.com/ppm/MCE/ * Update t/01_load_signal_arg.t -- added check for $ENV{TEMP} This fixes issue seen under Cygwin 1.007 Thu Nov 15 21:30:00 EST 2012 * At last, the "Voila" release :) * Small change to __DIE__ and __WARN__ signal handling for spawn method 1.006 Thu Nov 15 03:30:00 EST 2012 * Added description section to MCE::Signal's Perl doc * Do not set trap on __DIE__ and __WARN__ inside MCE::Signal * Localized __DIE__ and __WARN__ handlers inside MCE instead * Clarify the use of threads in documentation 1.005 Tue Nov 13 06:11:00 EST 2012 * Removed underscore from package globals in MCE::Signal * Optimized _worker_read_handle method in MCE * Updated files under examples/tbray/ 1.004 Mon Nov 12 01:50:00 EST 2012 * Updated examples/mce_usage.readme * Updated examples/wide_finder.pl * Added examples/tbray/README * Added examples/tbray/tbray_baseline1.pl * Added examples/tbray/tbray_baseline2.pl * Added examples/tbray/wf_mce1.pl * Added examples/tbray/wf_mce2.pl * Added examples/tbray/wf_mce3.pl (../wide_finder.pl moved here) * Added examples/tbray/wf_mmap.pl 1.003 Sat Nov 10 12:55:00 EST 2012 * Updated README * Updated images/06_Shared_Sockets.gif * Updated images/10_Scaling_Pings.gif * Added images/11_SNMP_Collection.gif * Minor updates to MCE::Signal 1.002 Thu Nov 08 01:13:10 EST 2012 * Renamed continue method to next 1.001 Wed Nov 07 23:58:20 EST 2012 * Added perl-MCE.spec to trunk http://code.google.com/p/many-core-engine-perl/source/browse/trunk/ * Added CREDITS * Added 3 new methods to MCE.pm: continue, last, and exit * Both foreach & forchunk now call run(1, {...}) to auto-shutdown workers 1.000 Mon Nov 05 10:00:00 EST 2012 * First release MCE-1.810/t/0000755000175000017500000000000013022753214011371 5ustar mariomarioMCE-1.810/t/04_norm_que_manager.t0000644000175000017500000000750713006204541015405 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE::Flow'; use_ok 'MCE::Queue'; } MCE::Flow::init { max_workers => 1 }; ############################################################################### ## MCE::Queue provides 3 operating modes (local, manager, and worker). ## This will test MCE::Queue (normal queue) by the MCE manager process. ## ## *{ 'MCE::Queue::clear' } = \&MCE::Queue::_mce_m_clear; ## *{ 'MCE::Queue::enqueue' } = \&MCE::Queue::_mce_m_enqueue; ## *{ 'MCE::Queue::dequeue' } = \&MCE::Queue::_mce_m_dequeue; ## *{ 'MCE::Queue::insert' } = \&MCE::Queue::_mce_m_insert; ## *{ 'MCE::Queue::pending' } = \&MCE::Queue::_pending; ## *{ 'MCE::Queue::peek' } = \&MCE::Queue::_peek; my (@a, $q, @r); ############################################################################### ## FIFO tests @a = (); $q = MCE::Queue->new( queue => \@a, type => $MCE::Queue::FIFO ); $q->enqueue('1', '2'); $q->enqueue('3'); $q->enqueue('4', '5'); is( join('', @a), '12345', 'fifo, check enqueue' ); @r = $q->dequeue(2); push @r, $q->dequeue; push @r, $q->dequeue(1); # Dequeue 1 explicitly is( join('', @r), '1234', 'fifo, check dequeue' ); is( join('', @a), '5', 'fifo, check array' ); $q->clear; is( scalar(@a), 0, 'fifo, check clear' ); $q->enqueue('a', 'b', 'c', 'd'); $q->insert( 1, 'e', 'f'); $q->insert( 3, 'g'); $q->insert( -2, 'h'); $q->insert( 7, 'i'); $q->insert( 9, 'j'); $q->insert( 20, 'k'); $q->insert(-10, 'l'); $q->insert(-12, 'm'); $q->insert(-20, 'n'); is( join('', @a) , 'nmalefgbhcidjk', 'fifo, check insert' ); is( $q->pending(), 14, 'fifo, check pending' ); is( $q->peek( ), 'n', 'fifo, check peek at head' ); is( $q->peek( 0), 'n', 'fifo, check peek at index 0' ); is( $q->peek( 2), 'a', 'fifo, check peek at index 2' ); is( $q->peek( 13), 'k', 'fifo, check peek at index 13' ); is( $q->peek( 20), undef, 'fifo, check peek at index 20' ); is( $q->peek( -2), 'j', 'fifo, check peek at index -2' ); is( $q->peek(-13), 'm', 'fifo, check peek at index -13' ); is( $q->peek(-14), 'n', 'fifo, check peek at index -14' ); is( $q->peek(-15), undef, 'fifo, check peek at index -15' ); is( $q->peek(-20), undef, 'fifo, check peek at index -20' ); ############################################################################### ## LIFO tests @a = (); $q = MCE::Queue->new( queue => \@a, type => $MCE::Queue::LIFO ); $q->enqueue('1', '2'); $q->enqueue('3'); $q->enqueue('4', '5'); ## Note (lifo) ## ## Enqueue appends to an array similarly to fifo ## Thus, the enqueue check is identical to fifo is( join('', @a), '12345', 'lifo, check enqueue' ); @r = $q->dequeue(2); push @r, $q->dequeue; push @r, $q->dequeue(1); # Dequeue 1 explicitly is( join('', @r), '5432', 'lifo, check dequeue' ); is( join('', @a), '1', 'lifo, check array' ); $q->clear; is( scalar(@a), 0, 'lifo, check clear' ); $q->enqueue('a', 'b', 'c', 'd'); $q->insert( 1, 'e', 'f'); $q->insert( 3, 'g'); $q->insert( -2, 'h'); $q->insert( 7, 'i'); $q->insert( 9, 'j'); $q->insert( 20, 'k'); $q->insert(-10, 'l'); $q->insert(-12, 'm'); $q->insert(-20, 'n'); is( join('', @a) , 'kjaibhcgefldmn', 'lifo, check insert' ); is( $q->pending(), 14, 'lifo, check pending' ); is( $q->peek( ), 'n', 'lifo, check peek at head' ); is( $q->peek( 0), 'n', 'lifo, check peek at index 0' ); is( $q->peek( 2), 'd', 'lifo, check peek at index 2' ); is( $q->peek( 13), 'k', 'lifo, check peek at index 13' ); is( $q->peek( 20), undef, 'lifo, check peek at index 20' ); is( $q->peek( -2), 'j', 'lifo, check peek at index -2' ); is( $q->peek(-13), 'm', 'lifo, check peek at index -13' ); is( $q->peek(-14), 'n', 'lifo, check peek at index -14' ); is( $q->peek(-15), undef, 'lifo, check peek at index -15' ); is( $q->peek(-20), undef, 'lifo, check peek at index -20' ); done_testing; MCE-1.810/t/04_prio_que_manager.t0000644000175000017500000001276313006204541015403 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE::Flow'; use_ok 'MCE::Queue'; } MCE::Flow::init { max_workers => 1 }; ############################################################################### ## MCE::Queue provides 3 operating modes (local, manager, and worker). ## This will test MCE::Queue (priority queue) by the MCE manager process. ## ## *{ 'MCE::Queue::clear' } = \&MCE::Queue::_mce_m_clear; ## *{ 'MCE::Queue::enqueuep' } = \&MCE::Queue::_mce_m_enqueuep; ## *{ 'MCE::Queue::dequeue' } = \&MCE::Queue::_mce_m_dequeue; ## *{ 'MCE::Queue::insertp' } = \&MCE::Queue::_mce_m_insertp; ## *{ 'MCE::Queue::pending' } = \&MCE::Queue::_pending; ## *{ 'MCE::Queue::peekp' } = \&MCE::Queue::_peekp; ## *{ 'MCE::Queue::peekh' } = \&MCE::Queue::_peekh; ## *{ 'MCE::Queue::heap' } = \&MCE::Queue::_heap; my ($q, @r, @h); ############################################################################### ## FIFO tests $q = MCE::Queue->new( type => $MCE::Queue::FIFO ); $q->enqueuep(5, '1', '2'); $q->enqueuep(5, '3'); $q->enqueuep(5, '4'); is( join('', @{ $q->_get_aref(5) }), '1234', 'fifo, check enqueuep' ); @r = $q->dequeue(2); push @r, $q->dequeue; is( join('', @r), '123', 'fifo, check dequeue' ); is( join('', @{ $q->_get_aref(5) }), '4', 'fifo, check array' ); $q->clear; is( $q->_get_aref(5), undef, 'fifo, check clear' ); $q->enqueuep(5, 'a', 'b', 'c', 'd'); $q->insertp(5, 1, 'e', 'f'); $q->insertp(5, 3, 'g'); $q->insertp(5, -2, 'h'); $q->insertp(5, 7, 'i'); $q->insertp(5, 9, 'j'); $q->insertp(5, 20, 'k'); $q->insertp(5, -10, 'l'); $q->insertp(5, -12, 'm'); $q->insertp(5, -20, 'n'); is( join('', @{ $q->_get_aref(5) }), 'nmalefgbhcidjk', 'fifo, check insertp' ); is( $q->pending(), 14, 'fifo, check pending' ); is( $q->peekp(5 ), 'n', 'fifo, check peekp at head' ); is( $q->peekp(5, 0), 'n', 'fifo, check peekp at index 0' ); is( $q->peekp(5, 2), 'a', 'fifo, check peekp at index 2' ); is( $q->peekp(5, 13), 'k', 'fifo, check peekp at index 13' ); is( $q->peekp(5, 20), undef, 'fifo, check peekp at index 20' ); is( $q->peekp(5, -2), 'j', 'fifo, check peekp at index -2' ); is( $q->peekp(5, -13), 'm', 'fifo, check peekp at index -13' ); is( $q->peekp(5, -14), 'n', 'fifo, check peekp at index -14' ); is( $q->peekp(5, -15), undef, 'fifo, check peekp at index -15' ); is( $q->peekp(5, -20), undef, 'fifo, check peekp at index -20' ); ############################################################################### ## LIFO tests $q = MCE::Queue->new( type => $MCE::Queue::LIFO ); $q->enqueuep(5, '1', '2'); $q->enqueuep(5, '3'); $q->enqueuep(5, '4'); ## Note (lifo) ## ## Enqueue appends to an array similarly to fifo ## Thus, the enqueuep check is identical to fifo is( join('', @{ $q->_get_aref(5) }), '1234', 'lifo, check enqueuep' ); @r = $q->dequeue(2); push @r, $q->dequeue; is( join('', @r), '432', 'lifo, check dequeue' ); is( join('', @{ $q->_get_aref(5) }), '1', 'lifo, check array' ); $q->clear; is( $q->_get_aref(5), undef, 'lifo, check clear' ); $q->enqueuep(5, 'a', 'b', 'c', 'd'); $q->insertp(5, 1, 'e', 'f'); $q->insertp(5, 3, 'g'); $q->insertp(5, -2, 'h'); $q->insertp(5, 7, 'i'); $q->insertp(5, 9, 'j'); $q->insertp(5, 20, 'k'); $q->insertp(5, -10, 'l'); $q->insertp(5, -12, 'm'); $q->insertp(5, -20, 'n'); is( join('', @{ $q->_get_aref(5) }), 'kjaibhcgefldmn', 'lifo, check insertp' ); is( $q->pending(), 14, 'lifo, check pending' ); is( $q->peekp(5 ), 'n', 'lifo, check peekp at head' ); is( $q->peekp(5, 0), 'n', 'lifo, check peekp at index 0' ); is( $q->peekp(5, 2), 'd', 'lifo, check peekp at index 2' ); is( $q->peekp(5, 13), 'k', 'lifo, check peekp at index 13' ); is( $q->peekp(5, 20), undef, 'lifo, check peekp at index 20' ); is( $q->peekp(5, -2), 'j', 'lifo, check peekp at index -2' ); is( $q->peekp(5, -13), 'm', 'lifo, check peekp at index -13' ); is( $q->peekp(5, -14), 'n', 'lifo, check peekp at index -14' ); is( $q->peekp(5, -15), undef, 'lifo, check peekp at index -15' ); is( $q->peekp(5, -20), undef, 'lifo, check peekp at index -20' ); ############################################################################### ## HIGHEST priority tests $q = MCE::Queue->new( porder => $MCE::Queue::HIGHEST, type => $MCE::Queue::FIFO ); $q->enqueuep(5, 'a', 'b'); # priority queue $q->enqueuep(7, 'e', 'f'); # priority queue $q->enqueue ( 'i', 'j'); # normal queue $q->enqueuep(8, 'g', 'h'); # priority queue $q->enqueuep(6, 'c', 'd'); # priority queue @h = $q->heap; is( join('', @h), '8765', 'highest, check heap' ); is( $q->peekh( 0), '8', 'lowest, check peekh at index 0' ); is( $q->peekh(-2), '6', 'lowest, check peekh at index -2' ); @r = $q->dequeue(10); is( join('', @r), 'ghefcdabij', 'highest, check dequeue' ); ############################################################################### ## LOWEST priority tests $q = MCE::Queue->new( porder => $MCE::Queue::LOWEST, type => $MCE::Queue::FIFO ); $q->enqueuep(5, 'a', 'b'); # priority queue $q->enqueuep(7, 'e', 'f'); # priority queue $q->enqueue ( 'i', 'j'); # normal queue $q->enqueuep(8, 'g', 'h'); # priority queue $q->enqueuep(6, 'c', 'd'); # priority queue @h = $q->heap; is( join('', @h), '5678', 'lowest, check heap' ); is( $q->peekh( 0), '5', 'lowest, check peekh at index 0' ); is( $q->peekh(-2), '7', 'lowest, check peekh at index -2' ); @r = $q->dequeue(10); is( join('', @r), 'abcdefghij', 'highest, check dequeue' ); done_testing; MCE-1.810/t/06_nodata_step.t0000644000175000017500000000052213006204541014357 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE::Step'; } MCE::Step::init { max_workers => 4 }; ## input_data is not required to run mce_step my @a = mce_step sub { MCE->gather(MCE->wid * 2); }; is( join('', sort @a), '2468', 'check gathered data' ); MCE::Step::finish; done_testing; MCE-1.810/t/05_mce_flow.t0000644000175000017500000000434113006204541013653 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE::Flow'; use_ok 'MCE::Queue'; } ## preparation my $in_file = MCE->tmp_dir . '/input.txt'; my $fh_data = \*DATA; open my $fh, '>', $in_file; binmode $fh; print {$fh} "1\n2\n3\n4\n5\n6\n7\n8\n9\n"; close $fh; ## output iterator to ensure output order sub output_iterator { my ($gather_ref) = @_; my %tmp; my $order_id = 1; @{ $gather_ref } = (); ## reset array return sub { my ($data_ref, $chunk_id) = @_; $tmp{ $chunk_id } = $data_ref; while (1) { last unless exists $tmp{$order_id}; push @{ $gather_ref }, @{ $tmp{$order_id} }; delete $tmp{$order_id++}; } return; }; } ## sub-tasks my $q = MCE::Queue->new; sub task_a { my ($mce, $chunk_ref, $chunk_id) = @_; my @ans; chomp @{ $chunk_ref }; push @ans, map { $_ * 2 } @{ $chunk_ref }; $q->enqueue( [ \@ans, $chunk_id ] ); # forward to task_b } sub task_b { while (defined (my $next_ref = $q->dequeue)) { my ($chunk_ref, $chunk_id) = @{ $next_ref }; my @ans; push @ans, map { $_ * 3 } @{ $chunk_ref }; MCE->gather(\@ans, $chunk_id); # send to output_iterator } } ## Reminder; MCE::Flow processes sub-tasks from left-to-right my $answers = '6 12 18 24 30 36 42 48 54'; my @a; MCE::Flow::init { max_workers => [ 2 , 2 ], # run with 2 workers for both sub-tasks task_name => [ 'a' , 'b' ], task_end => sub { my ($mce, $task_id, $task_name) = @_; if ($task_name eq 'a') { $q->enqueue((undef) x 2); } } }; mce_flow { gather => output_iterator(\@a) }, \&task_a, \&task_b, ( 1..9 ); is( join(' ', @a), $answers, 'check results for array' ); mce_flow_f { gather => output_iterator(\@a) }, \&task_a, \&task_b, $in_file; is( join(' ', @a), $answers, 'check results for path' ); mce_flow_f { gather => output_iterator(\@a) }, \&task_a, \&task_b, $fh_data; is( join(' ', @a), $answers, 'check results for glob' ); mce_flow_s { gather => output_iterator(\@a) }, \&task_a, \&task_b, 1, 9; is( join(' ', @a), $answers, 'check results for sequence' ); MCE::Flow::finish; ## cleanup unlink $in_file; done_testing; __DATA__ 1 2 3 4 5 6 7 8 9 MCE-1.810/t/05_mce_grep.t0000644000175000017500000000171013006204541013636 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE::Grep'; } ## preparation my $in_file = MCE->tmp_dir . '/input.txt'; my $fh_data = \*DATA; open my $fh, '>', $in_file; binmode $fh; print {$fh} "1\n2\n3\n4\n5\n6\n7\n8\n9\n"; close $fh; my @a; MCE::Grep::init { max_workers => 2 }; sub _task { chomp; $_ % 3 == 0 } ## mce_grep can take a code block, e.g: mce_grep { code } ( 1..9 ) ## below, workers will persist between runs @a = mce_grep \&_task, ( 1..9 ); is( join('', @a), '369', 'block_ref: check results for array' ); @a = mce_grep_f \&_task, $in_file; is( join('', @a), '369', 'block_ref: check results for path' ); @a = mce_grep_f \&_task, $fh_data; is( join('', @a), '369', 'block_ref: check results for glob' ); @a = mce_grep_s \&_task, 1, 9; is( join('', @a), '369', 'block_ref: check results for sequence' ); MCE::Grep::finish; ## cleanup unlink $in_file; done_testing; __DATA__ 1 2 3 4 5 6 7 8 9 MCE-1.810/t/04_prio_que_worker.t0000644000175000017500000001604113006204541015273 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE::Flow'; use_ok 'MCE::Queue'; } MCE::Flow::init { max_workers => 1 }; ############################################################################### ## MCE::Queue provides 3 operating modes (local, manager, and worker). ## This will test MCE::Queue (priority queue) by the MCE worker process. ## ## *{ 'MCE::Queue::clear' } = \&MCE::Queue::_mce_w_clear; ## *{ 'MCE::Queue::enqueuep' } = \&MCE::Queue::_mce_w_enqueuep; ## *{ 'MCE::Queue::dequeue' } = \&MCE::Queue::_mce_w_dequeue; ## *{ 'MCE::Queue::pending' } = \&MCE::Queue::_mce_w_pending; ## *{ 'MCE::Queue::insertp' } = \&MCE::Queue::_mce_w_insertp; ## *{ 'MCE::Queue::peekp' } = \&MCE::Queue::_mce_w_peekp; ## *{ 'MCE::Queue::peekh' } = \&MCE::Queue::_mce_w_peekh; ## *{ 'MCE::Queue::heap' } = \&MCE::Queue::_mce_w_heap; my ($q); ############################################################################### sub check_clear { my ($description) = @_; is( $q->_get_aref(5), undef, $description ); } sub check_enqueuep { my ($description) = @_; is( join('', @{ $q->_get_aref(5) }), '1234', $description ); } sub check_insertp { my ($description, $expected) = @_; is( join('', @{ $q->_get_aref(5) }), $expected, $description ); } sub check_pending { my ($description, $pending) = @_; is( $pending, 14, $description ); } sub check { my ($description, $expected, $value) = @_; is( $value, $expected, $description ); } ############################################################################### ## FIFO tests $q = MCE::Queue->new( type => $MCE::Queue::FIFO ); sub check_dequeue_fifo { my (@r) = @_; is( join('', @r), '123', 'fifo, check dequeue' ); is( join('', @{ $q->_get_aref(5) }), '4', 'fifo, check array' ); } mce_flow sub { my ($mce) = @_; $q->enqueuep(5, '1', '2'); $q->enqueuep(5, '3'); $q->enqueuep(5, '4'); MCE->do('check_enqueuep', 'fifo, check enqueuep'); my @r = $q->dequeue(2); push @r, $q->dequeue; MCE->do('check_dequeue_fifo', @r); $q->clear; MCE->do('check_clear', 'fifo, check clear'); $q->enqueuep(5, 'a', 'b', 'c', 'd'); $q->insertp(5, 1, 'e', 'f'); $q->insertp(5, 3, 'g'); $q->insertp(5, -2, 'h'); $q->insertp(5, 7, 'i'); $q->insertp(5, 9, 'j'); $q->insertp(5, 20, 'k'); $q->insertp(5, -10, 'l'); $q->insertp(5, -12, 'm'); $q->insertp(5, -20, 'n'); MCE->do('check_insertp', 'fifo, check insertp', 'nmalefgbhcidjk'); MCE->do('check_pending', 'fifo, check pending', $q->pending()); MCE->do('check', 'fifo, check peekp at head ', 'n', $q->peekp(5 )); MCE->do('check', 'fifo, check peekp at index 0', 'n', $q->peekp(5, 0)); MCE->do('check', 'fifo, check peekp at index 2', 'a', $q->peekp(5, 2)); MCE->do('check', 'fifo, check peekp at index 13', 'k', $q->peekp(5, 13)); MCE->do('check', 'fifo, check peekp at index 20', undef, $q->peekp(5, 20)); MCE->do('check', 'fifo, check peekp at index -2', 'j', $q->peekp(5, -2)); MCE->do('check', 'fifo, check peekp at index -13', 'm', $q->peekp(5, -13)); MCE->do('check', 'fifo, check peekp at index -14', 'n', $q->peekp(5, -14)); MCE->do('check', 'fifo, check peekp at index -15', undef, $q->peekp(5, -15)); MCE->do('check', 'fifo, check peekp at index -20', undef, $q->peekp(5, -20)); return; }; MCE::Flow::finish; ############################################################################### ## LIFO tests $q = MCE::Queue->new( type => $MCE::Queue::LIFO ); sub check_dequeue_lifo { my (@r) = @_; is( join('', @r), '432', 'lifo, check dequeue' ); is( join('', @{ $q->_get_aref(5) }), '1', 'lifo, check array' ); } mce_flow sub { my ($mce) = @_; $q->enqueuep(5, '1', '2'); $q->enqueuep(5, '3'); $q->enqueuep(5, '4'); MCE->do('check_enqueuep', 'lifo, check enqueuep'); my @r = $q->dequeue(2); push @r, $q->dequeue; MCE->do('check_dequeue_lifo', @r); $q->clear; MCE->do('check_clear', 'lifo, check clear'); $q->enqueuep(5, 'a', 'b', 'c', 'd'); $q->insertp(5, 1, 'e', 'f'); $q->insertp(5, 3, 'g'); $q->insertp(5, -2, 'h'); $q->insertp(5, 7, 'i'); $q->insertp(5, 9, 'j'); $q->insertp(5, 20, 'k'); $q->insertp(5, -10, 'l'); $q->insertp(5, -12, 'm'); $q->insertp(5, -20, 'n'); MCE->do('check_insertp', 'lifo, check insertp', 'kjaibhcgefldmn'); MCE->do('check_pending', 'lifo, check pending', $q->pending()); MCE->do('check', 'lifo, check peekp at head ', 'n', $q->peekp(5 )); MCE->do('check', 'lifo, check peekp at index 0', 'n', $q->peekp(5, 0)); MCE->do('check', 'lifo, check peekp at index 2', 'd', $q->peekp(5, 2)); MCE->do('check', 'lifo, check peekp at index 13', 'k', $q->peekp(5, 13)); MCE->do('check', 'lifo, check peekp at index 20', undef, $q->peekp(5, 20)); MCE->do('check', 'lifo, check peekp at index -2', 'j', $q->peekp(5, -2)); MCE->do('check', 'lifo, check peekp at index -13', 'm', $q->peekp(5, -13)); MCE->do('check', 'lifo, check peekp at index -14', 'n', $q->peekp(5, -14)); MCE->do('check', 'lifo, check peekp at index -15', undef, $q->peekp(5, -15)); MCE->do('check', 'lifo, check peekp at index -20', undef, $q->peekp(5, -20)); return; }; MCE::Flow::finish; ############################################################################### ## HIGHEST priority tests, mix-mode (normal and priority) $q = MCE::Queue->new( porder => $MCE::Queue::HIGHEST, type => $MCE::Queue::FIFO ); mce_flow sub { my ($mce) = @_; $q->enqueuep(5, 'a', 'b'); # priority queue $q->enqueuep(7, 'e', 'f'); # priority queue $q->enqueue ( 'i', 'j'); # normal queue $q->enqueuep(8, 'g', 'h'); # priority queue $q->enqueuep(6, 'c', 'd'); # priority queue my @h = $q->heap; MCE->do('check', 'highest, check heap', '8765', join('', @h)); MCE->do('check', 'highest, check peekh at index 0', '8', $q->peekh( 0)); MCE->do('check', 'highest, check peekh at index -2', '6', $q->peekh(-2)); my @r = $q->dequeue(10); MCE->do('check', 'highest, check dequeue', 'ghefcdabij', join('', @r)); return; }; MCE::Flow::finish; ############################################################################### ## LOWEST priority tests, mix-mode (normal and priority) $q = MCE::Queue->new( porder => $MCE::Queue::LOWEST, type => $MCE::Queue::FIFO ); mce_flow sub { my ($mce) = @_; $q->enqueuep(5, 'a', 'b'); # priority queue $q->enqueuep(7, 'e', 'f'); # priority queue $q->enqueue ( 'i', 'j'); # normal queue $q->enqueuep(8, 'g', 'h'); # priority queue $q->enqueuep(6, 'c', 'd'); # priority queue my @h = $q->heap; MCE->do('check', 'lowest, check heap', '5678', join('', @h)); MCE->do('check', 'lowest, check peekh at index 0', '5', $q->peekh( 0)); MCE->do('check', 'lowest, check peekh at index -2', '7', $q->peekh(-2)); my @r = $q->dequeue(10); MCE->do('check', 'lowest, check dequeue', 'abcdefghij', join('', @r)); return; }; MCE::Flow::finish; done_testing; MCE-1.810/t/04_norm_que_local.t0000644000175000017500000000756613006204541015072 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE::Queue'; } ############################################################################### ## MCE::Queue provides 3 operating modes (local, manager, and worker). ## This will test MCE::Queue (normal queue) in local mode. ## ## Local mode is selected when MCE is not present, during importing of ## MCE::Queue, or when initiating queues from inside the worker process. ## ## *{ 'MCE::Queue::clear' } = \&MCE::Queue::_clear; ## *{ 'MCE::Queue::enqueue' } = \&MCE::Queue::_enqueue; ## *{ 'MCE::Queue::dequeue' } = \&MCE::Queue::_dequeue; ## *{ 'MCE::Queue::insert' } = \&MCE::Queue::_insert; ## *{ 'MCE::Queue::pending' } = \&MCE::Queue::_pending; ## *{ 'MCE::Queue::peek' } = \&MCE::Queue::_peek; my (@a, $q, @r); ############################################################################### ## FIFO tests @a = (); $q = MCE::Queue->new( queue => \@a, type => $MCE::Queue::FIFO ); $q->enqueue('1', '2'); $q->enqueue('3'); $q->enqueue('4', '5'); is( join('', @a), '12345', 'fifo, check enqueue' ); @r = $q->dequeue(2); push @r, $q->dequeue; push @r, $q->dequeue(1); # Dequeue 1 explicitly is( join('', @r), '1234', 'fifo, check dequeue' ); is( join('', @a), '5', 'fifo, check array' ); $q->clear; is( scalar(@a), 0, 'fifo, check clear' ); $q->enqueue('a', 'b', 'c', 'd'); $q->insert( 1, 'e', 'f'); $q->insert( 3, 'g'); $q->insert( -2, 'h'); $q->insert( 7, 'i'); $q->insert( 9, 'j'); $q->insert( 20, 'k'); $q->insert(-10, 'l'); $q->insert(-12, 'm'); $q->insert(-20, 'n'); is( join('', @a) , 'nmalefgbhcidjk', 'fifo, check insert' ); is( $q->pending(), 14, 'fifo, check pending' ); is( $q->peek( ), 'n', 'fifo, check peek at head' ); is( $q->peek( 0), 'n', 'fifo, check peek at index 0' ); is( $q->peek( 2), 'a', 'fifo, check peek at index 2' ); is( $q->peek( 13), 'k', 'fifo, check peek at index 13' ); is( $q->peek( 20), undef, 'fifo, check peek at index 20' ); is( $q->peek( -2), 'j', 'fifo, check peek at index -2' ); is( $q->peek(-13), 'm', 'fifo, check peek at index -13' ); is( $q->peek(-14), 'n', 'fifo, check peek at index -14' ); is( $q->peek(-15), undef, 'fifo, check peek at index -15' ); is( $q->peek(-20), undef, 'fifo, check peek at index -20' ); ############################################################################### ## LIFO tests @a = (); $q = MCE::Queue->new( queue => \@a, type => $MCE::Queue::LIFO ); $q->enqueue('1', '2'); $q->enqueue('3'); $q->enqueue('4', '5'); ## Note (lifo) ## ## Enqueue appends to an array similarly to fifo ## Thus, the enqueue check is identical to fifo is( join('', @a), '12345', 'lifo, check enqueue' ); @r = $q->dequeue(2); push @r, $q->dequeue; push @r, $q->dequeue(1); # Dequeue 1 explicitly is( join('', @r), '5432', 'lifo, check dequeue' ); is( join('', @a), '1', 'lifo, check array' ); $q->clear; is( scalar(@a), 0, 'lifo, check clear' ); $q->enqueue('a', 'b', 'c', 'd'); $q->insert( 1, 'e', 'f'); $q->insert( 3, 'g'); $q->insert( -2, 'h'); $q->insert( 7, 'i'); $q->insert( 9, 'j'); $q->insert( 20, 'k'); $q->insert(-10, 'l'); $q->insert(-12, 'm'); $q->insert(-20, 'n'); is( join('', @a) , 'kjaibhcgefldmn', 'lifo, check insert' ); is( $q->pending(), 14, 'lifo, check pending' ); is( $q->peek( ), 'n', 'lifo, check peek at head' ); is( $q->peek( 0), 'n', 'lifo, check peek at index 0' ); is( $q->peek( 2), 'd', 'lifo, check peek at index 2' ); is( $q->peek( 13), 'k', 'lifo, check peek at index 13' ); is( $q->peek( 20), undef, 'lifo, check peek at index 20' ); is( $q->peek( -2), 'j', 'lifo, check peek at index -2' ); is( $q->peek(-13), 'm', 'lifo, check peek at index -13' ); is( $q->peek(-14), 'n', 'lifo, check peek at index -14' ); is( $q->peek(-15), undef, 'lifo, check peek at index -15' ); is( $q->peek(-20), undef, 'lifo, check peek at index -20' ); done_testing; MCE-1.810/t/03_user_args.t0000644000175000017500000000162713006204541014054 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE::Flow'; } MCE::Flow::init { max_workers => 1 }; sub check_hello { my ($arg1, $arg2) = @_; is( $arg1, 'hello', 'check user_args, hello' ); is( $arg2, 'there', 'check user_args, there' ); return; } sub check_other { my ($arg1, $arg2) = @_; is( $arg1, 'sunny', 'check user_args, sunny' ); is( $arg2, 'today', 'check user_args, today' ); return; } ## Workers persist between runs when passed a reference to a subroutine. sub task { my ($arg1, $arg2) = @{ MCE->user_args }; if ($arg1 eq 'hello') { MCE->do('check_hello', $arg1, $arg2); } else { MCE->do('check_other', $arg1, $arg2); } return; } mce_flow { user_args => [ 'hello', 'there' ] }, \&task; mce_flow { user_args => [ 'sunny', 'today' ] }, \&task; ## Shutdown workers. MCE::Flow::finish; done_testing; MCE-1.810/t/01_load_signal_arg.t0000644000175000017500000000227013006204541015160 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; ## Default is $MCE::Signal::tmp_dir which points to $ENV{TEMP} if defined. ## Otherwise, pass argument to module wanting /dev/shm versus /tmp for ## temporary files. MCE::Signal falls back to /tmp unless /dev/shm exists. ## ## One optional argument not tested here is -keep_tmp_dir which omits the ## removal of $tmp_dir on exit. A message is displayed by MCE::Signal stating ## the location of $tmp_dir when exiting. ## ## Always load MCE::Signal before MCE when wanting to export or pass options. our $tmp_dir; my $msg_eq = 'Check tmp_dir matches ^/dev/shm/'; my $msg_ne = 'Check tmp_dir does not match ^/dev/shm/'; BEGIN { use_ok('MCE::Signal', qw( $tmp_dir -use_dev_shm )); if (! exists $ENV{TEMP} && -d '/dev/shm' && -w '/dev/shm') { ok($tmp_dir =~ m{^/dev/shm/}x, $msg_eq); } elsif (exists $ENV{TEMP} && not (-d $ENV{TEMP} && -w $ENV{TEMP})) { if (-d '/dev/shm' && -w '/dev/shm') { ok($tmp_dir =~ m{^/dev/shm/}x, $msg_eq); } else { ok($tmp_dir !~ m{^/dev/shm/}x, $msg_ne); } } else { ok($tmp_dir !~ m{^/dev/shm/}x, $msg_ne); } use_ok('MCE'); } done_testing; MCE-1.810/t/05_mce_step.t0000644000175000017500000000372613006204541013665 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE::Step'; } ## preparation my $in_file = MCE->tmp_dir . '/input.txt'; my $fh_data = \*DATA; open my $fh, '>', $in_file; binmode $fh; print {$fh} "1\n2\n3\n4\n5\n6\n7\n8\n9\n"; close $fh; ## output iterator to ensure output order sub output_iterator { my ($gather_ref) = @_; my %tmp; my $order_id = 1; @{ $gather_ref } = (); ## reset array return sub { my ($data_ref, $chunk_id) = @_; $tmp{ $chunk_id } = $data_ref; while (1) { last unless exists $tmp{$order_id}; push @{ $gather_ref }, @{ $tmp{$order_id} }; delete $tmp{$order_id++}; } return; }; } ## sub-tasks sub task_a { my ($mce, $chunk_ref, $chunk_id) = @_; my @ans; chomp @{ $chunk_ref }; push @ans, map { $_ * 2 } @{ $chunk_ref }; MCE->step(\@ans, $chunk_id); # forward to task_b } sub task_b { my ($mce, $chunk_ref, $chunk_id) = @_; my @ans; push @ans, map { $_ * 3 } @{ $chunk_ref }; MCE->gather(\@ans, $chunk_id); # send to output_iterator } ## Reminder; MCE::Step processes sub-tasks from left-to-right my $answers = '6 12 18 24 30 36 42 48 54'; my @a; MCE::Step::init { max_workers => [ 2 , 2 ], # run with 2 workers for both sub-tasks task_name => [ 'a' , 'b' ] }; mce_step { gather => output_iterator(\@a) }, \&task_a, \&task_b, ( 1..9 ); is( join(' ', @a), $answers, 'check results for array' ); mce_step_f { gather => output_iterator(\@a) }, \&task_a, \&task_b, $in_file; is( join(' ', @a), $answers, 'check results for path' ); mce_step_f { gather => output_iterator(\@a) }, \&task_a, \&task_b, $fh_data; is( join(' ', @a), $answers, 'check results for glob' ); mce_step_s { gather => output_iterator(\@a) }, \&task_a, \&task_b, 1, 9; is( join(' ', @a), $answers, 'check results for sequence' ); MCE::Step::finish; ## cleanup unlink $in_file; done_testing; __DATA__ 1 2 3 4 5 6 7 8 9 MCE-1.810/t/06_nodata_flow.t0000644000175000017500000000052213006204541014353 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE::Flow'; } MCE::Flow::init { max_workers => 4 }; ## input_data is not required to run mce_flow my @a = mce_flow sub { MCE->gather(MCE->wid * 2); }; is( join('', sort @a), '2468', 'check gathered data' ); MCE::Flow::finish; done_testing; MCE-1.810/t/04_prio_que_local.t0000644000175000017500000001304213006204541015052 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE::Queue'; } ############################################################################### ## MCE::Queue provides 3 operating modes (local, manager, and worker). ## This will test MCE::Queue (priority queue) in local mode. ## ## Local mode is selected when MCE is not present, during importing of ## MCE::Queue, or when initiating queues from inside the worker process. ## ## *{ 'MCE::Queue::clear' } = \&MCE::Queue::_clear; ## *{ 'MCE::Queue::enqueuep' } = \&MCE::Queue::_enqueuep; ## *{ 'MCE::Queue::dequeue' } = \&MCE::Queue::_dequeue; ## *{ 'MCE::Queue::insertp' } = \&MCE::Queue::_insertp; ## *{ 'MCE::Queue::pending' } = \&MCE::Queue::_pending; ## *{ 'MCE::Queue::peekp' } = \&MCE::Queue::_peekp; ## *{ 'MCE::Queue::peekh' } = \&MCE::Queue::_peekh; ## *{ 'MCE::Queue::heap' } = \&MCE::Queue::_heap; my ($q, @r, @h); ############################################################################### ## FIFO tests $q = MCE::Queue->new( type => $MCE::Queue::FIFO ); $q->enqueuep(5, '1', '2'); $q->enqueuep(5, '3'); $q->enqueuep(5, '4'); is( join('', @{ $q->_get_aref(5) }), '1234', 'fifo, check enqueuep' ); @r = $q->dequeue(2); push @r, $q->dequeue; is( join('', @r), '123', 'fifo, check dequeue' ); is( join('', @{ $q->_get_aref(5) }), '4', 'fifo, check array' ); $q->clear; is( $q->_get_aref(5), undef, 'fifo, check clear' ); $q->enqueuep(5, 'a', 'b', 'c', 'd'); $q->insertp(5, 1, 'e', 'f'); $q->insertp(5, 3, 'g'); $q->insertp(5, -2, 'h'); $q->insertp(5, 7, 'i'); $q->insertp(5, 9, 'j'); $q->insertp(5, 20, 'k'); $q->insertp(5, -10, 'l'); $q->insertp(5, -12, 'm'); $q->insertp(5, -20, 'n'); is( join('', @{ $q->_get_aref(5) }), 'nmalefgbhcidjk', 'fifo, check insertp' ); is( $q->pending(), 14, 'fifo, check pending' ); is( $q->peekp(5 ), 'n', 'fifo, check peekp at head' ); is( $q->peekp(5, 0), 'n', 'fifo, check peekp at index 0' ); is( $q->peekp(5, 2), 'a', 'fifo, check peekp at index 2' ); is( $q->peekp(5, 13), 'k', 'fifo, check peekp at index 13' ); is( $q->peekp(5, 20), undef, 'fifo, check peekp at index 20' ); is( $q->peekp(5, -2), 'j', 'fifo, check peekp at index -2' ); is( $q->peekp(5, -13), 'm', 'fifo, check peekp at index -13' ); is( $q->peekp(5, -14), 'n', 'fifo, check peekp at index -14' ); is( $q->peekp(5, -15), undef, 'fifo, check peekp at index -15' ); is( $q->peekp(5, -20), undef, 'fifo, check peekp at index -20' ); ############################################################################### ## LIFO tests $q = MCE::Queue->new( type => $MCE::Queue::LIFO ); $q->enqueuep(5, '1', '2'); $q->enqueuep(5, '3'); $q->enqueuep(5, '4'); ## Note (lifo) ## ## Enqueue appends to an array similarly to fifo ## Thus, the enqueuep check is identical to fifo is( join('', @{ $q->_get_aref(5) }), '1234', 'lifo, check enqueuep' ); @r = $q->dequeue(2); push @r, $q->dequeue; is( join('', @r), '432', 'lifo, check dequeue' ); is( join('', @{ $q->_get_aref(5) }), '1', 'lifo, check array' ); $q->clear; is( $q->_get_aref(5), undef, 'lifo, check clear' ); $q->enqueuep(5, 'a', 'b', 'c', 'd'); $q->insertp(5, 1, 'e', 'f'); $q->insertp(5, 3, 'g'); $q->insertp(5, -2, 'h'); $q->insertp(5, 7, 'i'); $q->insertp(5, 9, 'j'); $q->insertp(5, 20, 'k'); $q->insertp(5, -10, 'l'); $q->insertp(5, -12, 'm'); $q->insertp(5, -20, 'n'); is( join('', @{ $q->_get_aref(5) }), 'kjaibhcgefldmn', 'lifo, check insertp' ); is( $q->pending(), 14, 'lifo, check pending' ); is( $q->peekp(5 ), 'n', 'lifo, check peekp at head' ); is( $q->peekp(5, 0), 'n', 'lifo, check peekp at index 0' ); is( $q->peekp(5, 2), 'd', 'lifo, check peekp at index 2' ); is( $q->peekp(5, 13), 'k', 'lifo, check peekp at index 13' ); is( $q->peekp(5, 20), undef, 'lifo, check peekp at index 20' ); is( $q->peekp(5, -2), 'j', 'lifo, check peekp at index -2' ); is( $q->peekp(5, -13), 'm', 'lifo, check peekp at index -13' ); is( $q->peekp(5, -14), 'n', 'lifo, check peekp at index -14' ); is( $q->peekp(5, -15), undef, 'lifo, check peekp at index -15' ); is( $q->peekp(5, -20), undef, 'lifo, check peekp at index -20' ); ############################################################################### ## HIGHEST priority tests $q = MCE::Queue->new( porder => $MCE::Queue::HIGHEST, type => $MCE::Queue::FIFO ); $q->enqueuep(5, 'a', 'b'); # priority queue $q->enqueuep(7, 'e', 'f'); # priority queue $q->enqueue ( 'i', 'j'); # normal queue $q->enqueuep(8, 'g', 'h'); # priority queue $q->enqueuep(6, 'c', 'd'); # priority queue @h = $q->heap; is( join('', @h), '8765', 'highest, check heap' ); is( $q->peekh( 0), '8', 'lowest, check peekh at index 0' ); is( $q->peekh(-2), '6', 'lowest, check peekh at index -2' ); @r = $q->dequeue(10); is( join('', @r), 'ghefcdabij', 'highest, check dequeue' ); ############################################################################### ## LOWEST priority tests $q = MCE::Queue->new( porder => $MCE::Queue::LOWEST, type => $MCE::Queue::FIFO ); $q->enqueuep(5, 'a', 'b'); # priority queue $q->enqueuep(7, 'e', 'f'); # priority queue $q->enqueue ( 'i', 'j'); # normal queue $q->enqueuep(8, 'g', 'h'); # priority queue $q->enqueuep(6, 'c', 'd'); # priority queue @h = $q->heap; is( join('', @h), '5678', 'lowest, check heap' ); is( $q->peekh( 0), '5', 'lowest, check peekh at index 0' ); is( $q->peekh(-2), '7', 'lowest, check peekh at index -2' ); @r = $q->dequeue(10); is( join('', @r), 'abcdefghij', 'highest, check dequeue' ); done_testing; MCE-1.810/t/00_required_modules.t0000644000175000017500000000065013006204541015422 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; ## The following are minimum Perl modules required by MCE BEGIN { use_ok('Fcntl', qw( :flock O_CREAT O_TRUNC O_RDWR O_RDONLY )); } BEGIN { use_ok('File::Path', qw( rmtree )); } BEGIN { use_ok('Socket', qw( :DEFAULT :crlf )); } BEGIN { use_ok('Storable', 2.04, qw( store retrieve freeze thaw )); } BEGIN { use_ok('Time::HiRes', qw( time )); } done_testing; MCE-1.810/t/03_chunk_size.t0000644000175000017500000000156513006204541014225 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE'; } my @ans; sub callback { my ($element) = @_; push @ans, $element; return; } my $mce = MCE->new( max_workers => 2, user_func => sub { my ($self, $chunk_ref, $chunk_id) = @_; for ( @{ $chunk_ref } ) { MCE->do('callback', $_); } return; } ); @ans = (); $mce->process([ 0 .. 3 ], { chunk_size => 1 }); is( join('', sort @ans), '0123', 'check that ans is correct for chunk_size of 1' ); @ans = (); $mce->process([ 0 .. 7 ], { chunk_size => 2 }); is( join('', sort @ans), '01234567', 'check that ans is correct for chunk_size of 2' ); @ans = (); $mce->process([ 0 .. 9 ], { chunk_size => 4 }); is( join('', sort @ans), '0123456789', 'check that ans is correct for chunk_size of 4' ); $mce->shutdown(); done_testing; MCE-1.810/t/01_load_signal_export.t0000644000175000017500000000037413006204541015733 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; ## Always load MCE::Signal before MCE when wanting to export or pass options. BEGIN { use_ok('MCE::Signal', qw( $tmp_dir sys_cmd stop_and_exit )); use_ok('MCE'); } done_testing; MCE-1.810/t/05_mce_loop.t0000644000175000017500000000313713006204541013657 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE::Loop'; } ## preparation my $in_file = MCE->tmp_dir . '/input.txt'; my $fh_data = \*DATA; open my $fh, '>', $in_file; binmode $fh; print {$fh} "1\n2\n3\n4\n5\n6\n7\n8\n9\n"; close $fh; ## output iterator to ensure output order sub output_iterator { my ($gather_ref) = @_; my %tmp; my $order_id = 1; @{ $gather_ref } = (); ## reset array return sub { my ($data_ref, $chunk_id) = @_; $tmp{ $chunk_id } = $data_ref; while (1) { last unless exists $tmp{$order_id}; push @{ $gather_ref }, @{ $tmp{$order_id} }; delete $tmp{$order_id++}; } return; }; } ## sub-task sub _task { my ($mce, $chunk_ref, $chunk_id) = @_; my @ans; chomp @{ $chunk_ref }; push @ans, map { $_ * 2 * 3 } @{ $chunk_ref }; MCE->gather(\@ans, $chunk_id); # send to output_iterator } my $answers = '6 12 18 24 30 36 42 48 54'; my @a; MCE::Loop::init { max_workers => 2, gather => output_iterator(\@a) }; ## mce_loop can take a code block, e.g: mce_loop { code } ( 1..9 ) ## below, workers will persist between runs mce_loop \&_task, ( 1..9 ); is( join(' ', @a), $answers, 'check results for array' ); mce_loop_f \&_task, $in_file; is( join(' ', @a), $answers, 'check results for path' ); mce_loop_f \&_task, $fh_data; is( join(' ', @a), $answers, 'check results for glob' ); mce_loop_s \&_task, 1, 9; is( join(' ', @a), $answers, 'check results for sequence' ); MCE::Loop::finish; ## cleanup unlink $in_file; done_testing; __DATA__ 1 2 3 4 5 6 7 8 9 MCE-1.810/t/05_mce_stream.t0000644000175000017500000000420513006204541014176 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE::Stream'; } ## preparation my $in_file = MCE->tmp_dir . '/input.txt'; my $fh_data = \*DATA; my $fh_pos = tell $fh_data; open my $fh, '>', $in_file; binmode $fh; print {$fh} "1\n2\n3\n4\n5\n6\n7\n8\n9\n"; close $fh; ## reminder ; MCE::Stream processes sub-tasks from right-to-left my $answers = '6 12 18 24 30 36 42 48 54'; my $ans_mix = '18 36 54'; my @a; MCE::Stream::init { max_workers => [ 2 , 2 ], # run with 2 workers for both sub-tasks task_name => [ 'b' , 'a' ] }; sub _task_a { chomp; $_ * 2 } sub _task_b { $_ * 3 } ## @a = mce_stream ... # @a is populated after running # not recommended for big input data @a = mce_stream \&_task_b, \&_task_a, ( 1..9 ); is( join(' ', @a), $answers, 'array: check results for array' ); @a = mce_stream_f \&_task_b, \&_task_a, $in_file; is( join(' ', @a), $answers, 'array: check results for path' ); @a = mce_stream_f \&_task_b, \&_task_a, $fh_data; is( join(' ', @a), $answers, 'array: check results for glob' ); @a = mce_stream_s \&_task_b, \&_task_a, 1, 9; is( join(' ', @a), $answers, 'array: check results for sequence' ); seek($fh_data, $fh_pos, 0); ## mce_stream \@a, ... # @a is populated while running # faster and consumes less memory mce_stream \@a, \&_task_b, \&_task_a, ( 1..9 ); is( join(' ', @a), $answers, 'array_ref: check results for array' ); mce_stream_f \@a, \&_task_b, \&_task_a, $in_file; is( join(' ', @a), $answers, 'array_ref: check results for path' ); mce_stream_f \@a, \&_task_b, \&_task_a, $fh_data; is( join(' ', @a), $answers, 'array_ref: check results for glob' ); mce_stream_s \@a, \&_task_b, \&_task_a, 1, 9; is( join(' ', @a), $answers, 'array_ref: check results for sequence' ); MCE::Stream::finish; @a = mce_stream { mode => 'map', code => sub { $_ * 2 * 3 } }, { mode => 'grep', code => sub { chomp; $_ % 3 == 0 } }, ( 1..9 ); is( join(' ', @a), $ans_mix, 'array: check results for mix_mode' ); MCE::Stream::finish; ## cleanup unlink $in_file; done_testing; __DATA__ 1 2 3 4 5 6 7 8 9 MCE-1.810/t/01_load_mce.t0000644000175000017500000000040213006204541013611 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; ## MCE::Signal is loaded by MCE automatically and is not neccessary in ## scripts unless wanting to export or pass options. BEGIN { use_ok('MCE'); use_ok('MCE::Util'); } done_testing; MCE-1.810/t/02_do_callback_result.t0000644000175000017500000000351113006204541015667 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE'; } my (@ans, @rpl, $mce); ############################################################################### sub callback { my ($wid) = @_; push @ans, $wid; return; } $mce = MCE->new( max_workers => 4, user_func => sub { MCE->do('callback', MCE->wid()); return; } ); @ans = (); $mce->run; is(join('', sort @ans), '1234', 'test1: check that wid is correct'); ############################################################################### sub callback2 { my ($wid) = @_; push @ans, $wid; return $wid * 2; } sub callback3 { my ($ans) = @_; push @rpl, $ans; return; } $mce = MCE->new( max_workers => 4, user_func => sub { my $reply = MCE->do('callback2', MCE->wid()); MCE->do('callback3', $reply); return; } ); @ans = (); @rpl = (); $mce->run; is(join('', sort @ans), '1234', 'test2: check that wid is correct'); is(join('', sort @rpl), '2468', 'test3: check that scalar is correct'); ############################################################################### sub callback4 { return @rpl; } sub callback5 { my ($a_ref) = @_; my %h = (); @ans = (); foreach (@{ $a_ref }) { push @ans, $_ / 2; $h{$_ / 2} = $_; } return %h; } sub callback6 { my ($h_ref) = @_; @rpl = (); foreach (sort keys %{ $h_ref }) { $rpl[$_ - 1] = $h_ref->{$_}; } return; } $mce = MCE->new( max_workers => 1, user_func => sub { my @reply = MCE->do('callback4'); my %reply = MCE->do('callback5', \@reply); MCE->do('callback6', \%reply); return; } ); $mce->run; is(join('', sort @ans), '1234', 'test4: check that list is correct'); is(join('', sort @rpl), '2468', 'test5: check that hash is correct'); done_testing; MCE-1.810/t/01_load_signal_tag.t0000644000175000017500000000035313006204541015162 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; ## Always load MCE::Signal before MCE when wanting to export or pass options. BEGIN { use_ok('MCE::Signal', qw( :all :tmp_dir )); use_ok('MCE'); } done_testing; MCE-1.810/t/06_relay.t0000644000175000017500000000113513006204541013173 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE::Flow'; } MCE::Flow::init { max_workers => 4, init_relay => 1, }; ## input_data is not required to run mce_flow ## ## statement(s) between relay_recv and relay ## are processed serially and orderly my @a = mce_flow sub { for my $i ( 1 .. 2 ) { my $n = MCE->relay_recv; MCE->gather( $n ); MCE->relay( sub { $_ += 1 } ); } }; my $v = MCE->relay_final; is( join('', sort @a), '12345678', 'check relayed data' ); is( $v, '9', 'check final value' ); MCE::Flow::finish; done_testing; MCE-1.810/t/05_mce_map.t0000644000175000017500000000177113006204541013465 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE::Map'; } ## preparation my $in_file = MCE->tmp_dir . '/input.txt'; my $fh_data = \*DATA; open my $fh, '>', $in_file; binmode $fh; print {$fh} "1\n2\n3\n4\n5\n6\n7\n8\n9\n"; close $fh; my $answers = '6 12 18 24 30 36 42 48 54'; my @a; MCE::Map::init { max_workers => 2 }; sub _task { chomp; $_ * 2 * 3 } ## mce_map can take a code block, e.g: mce_map { code } ( 1..9 ) ## below, workers will persist between runs @a = mce_map \&_task, ( 1..9 ); is( join(' ', @a), $answers, 'block_ref: check results for array' ); @a = mce_map_f \&_task, $in_file; is( join(' ', @a), $answers, 'block_ref: check results for path' ); @a = mce_map_f \&_task, $fh_data; is( join(' ', @a), $answers, 'block_ref: check results for glob' ); @a = mce_map_s \&_task, 1, 9; is( join(' ', @a), $answers, 'block_ref: check results for sequence' ); MCE::Map::finish; ## cleanup unlink $in_file; done_testing; __DATA__ 1 2 3 4 5 6 7 8 9 MCE-1.810/t/00_required_signals.t0000644000175000017500000000113713006204541015413 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; ## Optional signals detected by MCE::Signal and not tested here are ## $SIG{XCPU} & $SIG{XFSZ}. MCE::Signal assigns signal handlers for ## the following by default. ## ok(exists $SIG{HUP }, 'Check that $SIG{HUP} exists'); ok(exists $SIG{INT }, 'Check that $SIG{INT} exists'); ok(exists $SIG{PIPE}, 'Check that $SIG{PIPE} exists'); ok(exists $SIG{QUIT}, 'Check that $SIG{QUIT} exists'); ok(exists $SIG{TERM}, 'Check that $SIG{TERM} exists'); if ($^O ne 'MSWin32') { ok(exists $SIG{CHLD}, 'Check that $SIG{CHLD} exists'); } done_testing; MCE-1.810/t/02_do_callback_args.t0000644000175000017500000000136113006204541015306 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE'; } sub callback1 { my ($a_ref, $h_ref, $s_ref) = @_; is($a_ref->[1], 'two', 'check array reference'); is($h_ref->{'two'}, 'TWO', 'check hash reference'); is(${ $s_ref }, 'fall colors', 'check scalar reference'); return; } sub callback2 { my ($wid) = @_; is($wid, 1, 'check scalar value'); return; } my $mce = MCE->new( max_workers => 1, user_func => sub { my ($self) = @_; my @a = ('one', 'two'); my %h = ('one' => 'ONE', 'two' => 'TWO'); my $s = 'fall colors'; $self->do('callback1', \@a, \%h, \$s); $self->do('callback2', $self->wid()); return; } ); $mce->run; done_testing; MCE-1.810/t/04_norm_que_worker.t0000644000175000017500000001205213006204541015273 0ustar mariomario#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE::Flow'; use_ok 'MCE::Queue'; } MCE::Flow::init { max_workers => 1 }; ############################################################################### ## MCE::Queue provides 3 operating modes (local, manager, and worker). ## This will test MCE::Queue (normal queue) by the MCE worker process. ## ## *{ 'MCE::Queue::clear' } = \&MCE::Queue::_mce_w_clear; ## *{ 'MCE::Queue::enqueue' } = \&MCE::Queue::_mce_w_enqueue; ## *{ 'MCE::Queue::dequeue' } = \&MCE::Queue::_mce_w_dequeue; ## *{ 'MCE::Queue::insert' } = \&MCE::Queue::_mce_w_insert; ## *{ 'MCE::Queue::pending' } = \&MCE::Queue::_mce_w_pending; ## *{ 'MCE::Queue::peek' } = \&MCE::Queue::_mce_w_peek; my (@a, $q); ############################################################################### sub check_clear { my ($description) = @_; is( scalar(@a), 0, $description ); } sub check_enqueue { my ($description) = @_; is( join('', @a), '12345', $description ); } sub check_insert { my ($description, $expected) = @_; is( join('', @a), $expected, $description ); } sub check_pending { my ($description, $pending) = @_; is( $pending, 14, $description ); } sub check { my ($description, $expected, $value) = @_; is( $value, $expected, $description ); } ############################################################################### ## FIFO tests @a = (); $q = MCE::Queue->new( queue => \@a, type => $MCE::Queue::FIFO ); sub check_dequeue_fifo { my (@r) = @_; is( join('', @r), '1234', 'fifo, check dequeue' ); is( join('', @a), '5', 'fifo, check array' ); } mce_flow sub { my ($mce) = @_; $q->enqueue('1', '2'); $q->enqueue('3'); $q->enqueue('4', '5'); MCE->do('check_enqueue', 'fifo, check enqueue'); my @r = $q->dequeue(2); push @r, $q->dequeue; push @r, $q->dequeue(1); # Dequeue 1 explicitly MCE->do('check_dequeue_fifo', @r); $q->clear; MCE->do('check_clear', 'fifo, check clear'); $q->enqueue('a', 'b', 'c', 'd'); $q->insert( 1, 'e', 'f'); $q->insert( 3, 'g'); $q->insert( -2, 'h'); $q->insert( 7, 'i'); $q->insert( 9, 'j'); $q->insert( 20, 'k'); $q->insert(-10, 'l'); $q->insert(-12, 'm'); $q->insert(-20, 'n'); MCE->do('check_insert', 'fifo, check insert', 'nmalefgbhcidjk'); MCE->do('check_pending', 'fifo, check pending', $q->pending()); MCE->do('check', 'fifo, check peek at head ', 'n', $q->peek( )); MCE->do('check', 'fifo, check peek at index 0', 'n', $q->peek( 0)); MCE->do('check', 'fifo, check peek at index 2', 'a', $q->peek( 2)); MCE->do('check', 'fifo, check peek at index 13', 'k', $q->peek( 13)); MCE->do('check', 'fifo, check peek at index 20', undef, $q->peek( 20)); MCE->do('check', 'fifo, check peek at index -2', 'j', $q->peek( -2)); MCE->do('check', 'fifo, check peek at index -13', 'm', $q->peek(-13)); MCE->do('check', 'fifo, check peek at index -14', 'n', $q->peek(-14)); MCE->do('check', 'fifo, check peek at index -15', undef, $q->peek(-15)); MCE->do('check', 'fifo, check peek at index -20', undef, $q->peek(-20)); return; }; MCE::Flow::finish; ############################################################################### ## LIFO tests @a = (); $q = MCE::Queue->new( queue => \@a, type => $MCE::Queue::LIFO ); sub check_dequeue_lifo { my (@r) = @_; is( join('', @r), '5432', 'lifo, check dequeue' ); is( join('', @a), '1', 'lifo, check array' ); } mce_flow sub { my ($mce) = @_; $q->enqueue('1', '2'); $q->enqueue('3'); $q->enqueue('4', '5'); MCE->do('check_enqueue', 'lifo, check enqueue'); my @r = $q->dequeue(2); push @r, $q->dequeue; push @r, $q->dequeue(1); # Dequeue 1 explicitly MCE->do('check_dequeue_lifo', @r); $q->clear; MCE->do('check_clear', 'lifo, check clear'); $q->enqueue('a', 'b', 'c', 'd'); $q->insert( 1, 'e', 'f'); $q->insert( 3, 'g'); $q->insert( -2, 'h'); $q->insert( 7, 'i'); $q->insert( 9, 'j'); $q->insert( 20, 'k'); $q->insert(-10, 'l'); $q->insert(-12, 'm'); $q->insert(-20, 'n'); MCE->do('check_insert', 'lifo, check insert', 'kjaibhcgefldmn'); MCE->do('check_pending', 'lifo, check pending', $q->pending()); MCE->do('check', 'lifo, check peek at head ', 'n', $q->peek( )); MCE->do('check', 'lifo, check peek at index 0', 'n', $q->peek( 0)); MCE->do('check', 'lifo, check peek at index 2', 'd', $q->peek( 2)); MCE->do('check', 'lifo, check peek at index 13', 'k', $q->peek( 13)); MCE->do('check', 'lifo, check peek at index 20', undef, $q->peek( 20)); MCE->do('check', 'lifo, check peek at index -2', 'j', $q->peek( -2)); MCE->do('check', 'lifo, check peek at index -13', 'm', $q->peek(-13)); MCE->do('check', 'lifo, check peek at index -14', 'n', $q->peek(-14)); MCE->do('check', 'lifo, check peek at index -15', undef, $q->peek(-15)); MCE->do('check', 'lifo, check peek at index -20', undef, $q->peek(-20)); return; }; MCE::Flow::finish; done_testing; MCE-1.810/lib/0000755000175000017500000000000013022753214011674 5ustar mariomarioMCE-1.810/lib/MCE.pod0000644000175000017500000001522513022712437013013 0ustar mariomario =head1 NAME MCE - Many-Core Engine for Perl providing parallel processing capabilities =head1 VERSION This document describes MCE version 1.810 Many-Core Engine (MCE) for Perl helps enable a new level of performance by maximizing all available cores. =begin html

MCE

=end html =head1 DESCRIPTION MCE spawns a pool of workers and therefore does not fork a new process per each element of data. Instead, MCE follows a bank queuing model. Imagine the line being the data and bank-tellers the parallel workers. MCE enhances that model by adding the ability to chunk the next n elements from the input stream to the next available worker. =begin html

Bank Queuing Model

=end html =head1 SYNOPSIS This is a simplistic use case of MCE running with 5 workers. # Construction using the Core API use MCE; my $mce = MCE->new( max_workers => 5, user_func => sub { my ($mce) = @_; $mce->say("Hello from " . $mce->wid); } ); $mce->run; # Construction using a MCE model use MCE::Flow max_workers => 5; mce_flow sub { my ($mce) = @_; MCE->say("Hello from " . MCE->wid); }; The following is a demonstration for parsing a huge log file in parallel. use MCE::Loop; MCE::Loop::init { max_workers => 8, use_slurpio => 1 }; my $pattern = 'something'; my $hugefile = 'very_huge.file'; my @result = mce_loop_f { my ($mce, $slurp_ref, $chunk_id) = @_; # Quickly determine if a match is found. # Process the slurped chunk only if true. if ($$slurp_ref =~ /$pattern/m) { my @matches; # The following is fast on Unix, but performance degrades # drastically on Windows beyond 4 workers. open my $MEM_FH, '<', $slurp_ref; binmode $MEM_FH, ':raw'; while (<$MEM_FH>) { push @matches, $_ if (/$pattern/); } close $MEM_FH; # Therefore, use the following construction on Windows. while ( $$slurp_ref =~ /([^\n]+\n)/mg ) { my $line = $1; # save $1 to not lose the value push @matches, $line if ($line =~ /$pattern/); } # Gather matched lines. MCE->gather(@matches); } } $hugefile; print join('', @result); The next demonstration loops through a sequence of numbers with MCE::Flow. use MCE::Flow; my $N = shift || 4_000_000; sub compute_pi { my ( $beg_seq, $end_seq ) = @_; my ( $pi, $t ) = ( 0.0 ); foreach my $i ( $beg_seq .. $end_seq ) { $t = ( $i + 0.5 ) / $N; $pi += 4.0 / ( 1.0 + $t * $t ); } MCE->gather( $pi ); } # Compute bounds only, workers receive [ begin, end ] values MCE::Flow::init( chunk_size => 200_000, max_workers => 8, bounds_only => 1 ); my @ret = mce_flow_s sub { compute_pi( $_->[0], $_->[1] ); }, 0, $N - 1; my $pi = 0.0; $pi += $_ for @ret; printf "pi = %0.13f\n", $pi / $N; # 3.1415926535898 =head1 CORE MODULES Three modules make up the core engine for MCE. =over 3 =item L Provides the Core API for Many-Core Engine. The various MCE options are described here. =item L Temporary directory creation, cleanup, and signal handling. =item L Utility functions for Many-Core Engine. =back =head1 MCE EXTRAS There are 4 add-on modules for use with MCE. =over 3 =item L Provides a collection of sugar methods and output iterators for preserving output order. =item L Provides a simple semaphore implementation supporting threads and processes. =item L Provides a hybrid queuing implementation for MCE supporting normal queues and priority queues from a single module. MCE::Queue exchanges data via the core engine to enable queuing to work for both children (spawned from fork) and threads. =item L Enables workers to receive and pass on information orderly with zero involvement by the manager process while running. =back =head1 MCE MODELS The models take Many-Core Engine to a new level for ease of use. Two options (chunk_size and max_workers) are configured automatically as well as spawning and shutdown. =over 3 =item L Provides a parallel loop utilizing MCE for building creative loops. =item L A parallel flow model for building creative applications. This makes use of user_tasks in MCE. The author has full control when utilizing this model. MCE::Flow is similar to MCE::Loop, but allows for multiple code blocks to run in parallel with a slight change to syntax. =item L Provides a parallel grep implementation similar to the native grep function. =item L Provides a parallel map model similar to the native map function. =item L Provides a parallel step implementation utilizing MCE::Queue between user tasks. MCE::Step is a spin off from MCE::Flow with a touch of MCE::Stream. This model, introduced in 1.506, allows one to pass data from one sub-task into the next transparently. =item L Provides an efficient parallel implementation for chaining multiple maps and greps together through user_tasks and MCE::Queue. Like with MCE::Flow, MCE::Stream can run multiple code blocks in parallel with a slight change to syntax from MCE::Map and MCE::Grep. =back =head1 MISCELLANEOUS Miscellaneous additions included with the distribution. =over 3 =item L Describes various demonstrations for MCE including a Monte Carlo simulation. =item L Exports functions mapped directly to MCE methods; e.g. mce_wid. The module allows 3 options; :manager, :worker, and :getter. =back =head1 REQUIREMENTS Perl 5.8.0 or later. PDL::IO::Storable is required in scripts running PDL. =head1 SOURCE AND FURTHER READING The source, cookbook, and examples are hosted at GitHub. =over 3 =item * L =item * L =item * L =back =head1 SEE ALSO C provides data sharing capabilities for C. It includes C for running code asynchronously. =over 3 =item * L =item * L =back =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =head1 COPYRIGHT AND LICENSE Copyright (C) 2012-2016 by Mario E. Roy MCE is released under the same license as Perl. See L for more information. =cut MCE-1.810/lib/MCE.pm0000644000175000017500000016410313022712434012642 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## MCE - Many-Core Engine for Perl providing parallel processing capabilities. ## ############################################################################### package MCE; use strict; use warnings; no warnings qw( threads recursion uninitialized ); our $VERSION = '1.810'; ## no critic (BuiltinFunctions::ProhibitStringyEval) ## no critic (Subroutines::ProhibitSubroutinePrototypes) ## no critic (TestingAndDebugging::ProhibitNoStrict) use Carp (); my ($_has_threads, $_freeze, $_thaw, $_tid, $_oid); BEGIN { local $@; local $SIG{__DIE__}; if ($^O eq 'MSWin32' && !$INC{'threads.pm'}) { eval 'use threads; use threads::shared'; } elsif ($INC{'threads.pm'} && !$INC{'threads/shared.pm'}) { eval 'use threads::shared'; } $_has_threads = $INC{'threads.pm'} ? 1 : 0; $_tid = $_has_threads ? threads->tid() : 0; $_oid = "$$.$_tid"; eval 'PDL::no_clone_skip_warning()' if $INC{'PDL.pm'}; eval 'use PDL::IO::Storable' if $INC{'PDL.pm'}; if (!exists $INC{'PDL.pm'}) { eval 'use Sereal 3.008 qw( encode_sereal decode_sereal )'; if ( !$@ ) { $_freeze = sub { encode_sereal( @_, { freeze_callbacks => 1 } ) }; $_thaw = \&decode_sereal; } } if (!defined $_freeze) { require Storable; $_freeze = \&Storable::freeze; $_thaw = \&Storable::thaw; } return; } use Scalar::Util qw( looks_like_number refaddr weaken ); use Time::HiRes qw( sleep time ); use Symbol qw( qualify_to_ref ); use Socket qw( SOL_SOCKET SO_RCVBUF ); use MCE::Util qw( $LF ); use MCE::Signal; use MCE::Mutex; use bytes; our ($MCE, $RLA, $_que_template, $_que_read_size); our (%_valid_fields_new); my ($TOP_HDLR, $_is_MSWin32, $_is_winenv, $_prev_mce); my (%_valid_fields_task, %_params_allowed_args); BEGIN { ## Configure pack/unpack template for writing to and from the queue. ## Each entry contains 2 positive numbers: chunk_id & msg_id. ## Attempt 64-bit size, otherwize fall back to machine's word length. { local $@; eval { $_que_read_size = length pack('Q2', 0, 0); }; $_que_template = ($@) ? 'I2' : 'Q2'; $_que_read_size = length pack($_que_template, 0, 0); } ## Attributes used internally. ## _abort_msg _chn _com_lock _dat_lock _i_app_st _i_app_tb _i_wrk_st _wuf ## _chunk_id _mce_sid _mce_tid _pids _run_mode _single_dim _thrs _tids _wid ## _exiting _exit_pid _total_exited _total_running _total_workers _task_wid ## _send_cnt _sess_dir _spawned _state _status _task _task_id _wrk_status ## _init_pid _init_total_workers _last_sref _mgr_live _rla_data _seed ## ## _bsb_r_sock _bsb_w_sock _bse_r_sock _bse_w_sock _com_r_sock _com_w_sock ## _dat_r_sock _dat_w_sock _que_r_sock _que_w_sock _rla_r_sock _rla_w_sock ## _data_channels _lock_chn _mutex_n _caller %_valid_fields_new = map { $_ => 1 } qw( max_workers tmp_dir use_threads user_tasks task_end task_name freeze thaw chunk_size input_data sequence job_delay spawn_delay submit_delay RS flush_file flush_stderr flush_stdout stderr_file stdout_file use_slurpio interval user_args user_begin user_end user_func user_error user_output bounds_only gather init_relay on_post_exit on_post_run parallel_io loop_timeout max_retries posix_exit ); %_params_allowed_args = map { $_ => 1 } qw( chunk_size input_data sequence job_delay spawn_delay submit_delay RS flush_file flush_stderr flush_stdout stderr_file stdout_file use_slurpio interval user_args user_begin user_end user_func user_error user_output bounds_only gather init_relay on_post_exit on_post_run parallel_io loop_timeout max_retries ); %_valid_fields_task = map { $_ => 1 } qw( max_workers chunk_size input_data interval sequence task_end task_name bounds_only gather init_relay user_args user_begin user_end user_func RS parallel_io use_slurpio use_threads ); $_is_MSWin32 = ( $^O eq 'MSWin32' ) ? 1 : 0; $_is_winenv = ( $^O =~ /mswin|mingw|msys|cygwin/i ) ? 1 : 0; ## Create accessor functions. no strict 'refs'; no warnings 'redefine'; for my $_p (qw( chunk_size max_retries max_workers task_name tmp_dir user_args )) { *{ $_p } = sub () { my $self = shift; $self = $MCE unless ref($self); return $self->{$_p}; }; } for my $_p (qw( chunk_id sess_dir task_id task_wid wid )) { *{ $_p } = sub () { my $self = shift; $self = $MCE unless ref($self); return $self->{"_${_p}"}; }; } for my $_p (qw( freeze thaw )) { *{ $_p } = sub () { my $self = shift; $self = $MCE unless ref($self); return $self->{$_p}(@_); }; } $RLA = {}; return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Import routine. ## ############################################################################### use constant { SELF => 0, CHUNK => 1, CID => 2 }; our $_MCE_LOCK : shared = 1; our $_WIN_LOCK : shared = 1; my ($_def, $_imported) = ({}); sub import { my ($_class, $_pkg) = (shift, caller); my $_p = $_def->{$_pkg} = {}; ## Process module arguments. while ( my $_argument = shift ) { my $_arg = lc $_argument; $_p->{MAX_WORKERS} = shift, next if ( $_arg eq 'max_workers' ); $_p->{CHUNK_SIZE} = shift, next if ( $_arg eq 'chunk_size' ); $_p->{TMP_DIR} = shift, next if ( $_arg eq 'tmp_dir' ); $_p->{FREEZE} = shift, next if ( $_arg eq 'freeze' ); $_p->{THAW} = shift, next if ( $_arg eq 'thaw' ); if ( $_arg eq 'export_const' || $_arg eq 'const' ) { if ( shift eq '1' ) { no strict 'refs'; no warnings 'redefine'; *{ $_pkg.'::SELF' } = \&SELF; *{ $_pkg.'::CHUNK' } = \&CHUNK; *{ $_pkg.'::CID' } = \&CID; } next; } ## Sereal, if available, is used automatically by MCE 1.800 onwards. if ( $_arg eq 'sereal' ) { if ( shift eq '0' ) { require Storable; $_p->{FREEZE} = \&Storable::freeze; $_p->{THAW} = \&Storable::thaw; } next; } _croak("Error: ($_argument) invalid module option"); } return if $_imported++; ## Preload essential modules. require MCE::Core::Validation; require MCE::Core::Manager; require MCE::Core::Worker; no strict 'refs'; no warnings 'redefine'; *{ 'MCE::_parse_max_workers' } = \&MCE::Util::_parse_max_workers; ## Instantiate a module-level instance. $MCE = MCE->new( _module_instance => 1, max_workers => 0 ); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Define constants & variables. ## ############################################################################### use constant { MAX_CHUNK_SIZE => 1024 * 1024 * 64, # Maximum chunk size allowed # Max data channels. This cannot be greater than 8 on MSWin32. DATA_CHANNELS => ($^O eq 'MSWin32') ? 8 : 12, MAX_RECS_SIZE => 8192, # Reads number of records if N <= value # Reads number of bytes if N > value OUTPUT_W_ABT => 'W~ABT', # Worker has aborted OUTPUT_W_DNE => 'W~DNE', # Worker has completed OUTPUT_W_RLA => 'W~RLA', # Worker has relayed OUTPUT_W_EXT => 'W~EXT', # Worker has exited OUTPUT_A_ARY => 'A~ARY', # Array << Array OUTPUT_S_GLB => 'S~GLB', # Scalar << Glob FH OUTPUT_U_ITR => 'U~ITR', # User << Iterator OUTPUT_A_CBK => 'A~CBK', # Callback w/ multiple args OUTPUT_S_CBK => 'S~CBK', # Callback w/ 1 scalar arg OUTPUT_N_CBK => 'N~CBK', # Callback w/ no args OUTPUT_A_GTR => 'A~GTR', # Gather array/ref OUTPUT_S_GTR => 'S~GTR', # Gather scalar OUTPUT_O_SND => 'O~SND', # Send >> STDOUT OUTPUT_E_SND => 'E~SND', # Send >> STDERR OUTPUT_F_SND => 'F~SND', # Send >> File OUTPUT_D_SND => 'D~SND', # Send >> File descriptor OUTPUT_B_SYN => 'B~SYN', # Barrier sync - begin OUTPUT_E_SYN => 'E~SYN', # Barrier sync - end OUTPUT_S_IPC => 'S~IPC', # Change to win32 IPC READ_FILE => 0, # Worker reads file handle READ_MEMORY => 1, # Worker reads memory handle REQUEST_ARRAY => 0, # Worker requests next array chunk REQUEST_GLOB => 1, # Worker requests next glob chunk SENDTO_FILEV1 => 0, # Worker sends to 'file', $a, '/path' SENDTO_FILEV2 => 1, # Worker sends to 'file:/path', $a SENDTO_STDOUT => 2, # Worker sends to STDOUT SENDTO_STDERR => 3, # Worker sends to STDERR SENDTO_FD => 4, # Worker sends to file descriptor WANTS_UNDEF => 0, # Callee wants nothing WANTS_ARRAY => 1, # Callee wants list WANTS_SCALAR => 2, # Callee wants scalar WANTS_REF => 3 # Callee wants H/A/S ref }; my $_mce_count = 0; sub CLONE { $_tid = threads->tid() if $_has_threads; } sub DESTROY { if ( $_[0] && $_[0]->{_spawned} && $_[0]->{_init_pid} eq "$$.$_tid" ) { $_[0]->shutdown(1); } } END { if ( defined $MCE ) { if ( !$_has_threads || (defined $TOP_HDLR && !$TOP_HDLR->{use_threads}) ) { MCE::Flow->finish ( 'MCE' ) if $INC{'MCE/Flow.pm'}; MCE::Grep->finish ( 'MCE' ) if $INC{'MCE/Grep.pm'}; MCE::Loop->finish ( 'MCE' ) if $INC{'MCE/Loop.pm'}; MCE::Map->finish ( 'MCE' ) if $INC{'MCE/Map.pm'}; MCE::Step->finish ( 'MCE' ) if $INC{'MCE/Step.pm'}; MCE::Stream->finish ( 'MCE' ) if $INC{'MCE/Stream.pm'}; } $TOP_HDLR = undef if defined $TOP_HDLR; $MCE = undef; } } ############################################################################### ## ---------------------------------------------------------------------------- ## Plugin interface for external modules plugging into MCE, e.g. MCE::Queue. ## ############################################################################### my (%_plugin_function, @_plugin_loop_begin, @_plugin_loop_end); my (%_plugin_list, @_plugin_worker_init); sub _attach_plugin { my $_ext_module = caller; unless (exists $_plugin_list{$_ext_module}) { $_plugin_list{$_ext_module} = 1; my $_ext_output_function = $_[0]; my $_ext_output_loop_begin = $_[1]; my $_ext_output_loop_end = $_[2]; my $_ext_worker_init = $_[3]; if (ref $_ext_output_function eq 'HASH') { for my $_p (keys %{ $_ext_output_function }) { $_plugin_function{$_p} = $_ext_output_function->{$_p} unless (exists $_plugin_function{$_p}); } } push @_plugin_loop_begin, $_ext_output_loop_begin if (ref $_ext_output_loop_begin eq 'CODE'); push @_plugin_loop_end, $_ext_output_loop_end if (ref $_ext_output_loop_end eq 'CODE'); push @_plugin_worker_init, $_ext_worker_init if (ref $_ext_worker_init eq 'CODE'); } @_ = (); return; } ## Functions for saving and restoring $MCE. This is mainly helpful for ## modules using MCE. e.g. MCE::Map. sub _restore_state { $MCE = $_prev_mce; $_prev_mce = undef; return; } sub _save_state { $_prev_mce = $MCE; return; } ############################################################################### ## ---------------------------------------------------------------------------- ## New instance instantiation. ## ############################################################################### sub new { my ($class, %self) = @_; my $_pkg = exists $self{pkg} ? delete $self{pkg} : caller; @_ = (); bless(\%self, ref($class) || $class); $self{task_name} ||= 'MCE'; $self{max_workers} ||= $_def->{$_pkg}{MAX_WORKERS} || 1; $self{chunk_size} ||= $_def->{$_pkg}{CHUNK_SIZE} || 1; $self{tmp_dir} ||= $_def->{$_pkg}{TMP_DIR} || $MCE::Signal::tmp_dir; $self{freeze} ||= $_def->{$_pkg}{FREEZE} || $_freeze; $self{thaw} ||= $_def->{$_pkg}{THAW} || $_thaw; if (exists $self{_module_instance}) { $self{_init_total_workers} = $self{max_workers}; $self{_chunk_id} = $self{_task_wid} = $self{_wrk_status} = 0; $self{_spawned} = $self{_task_id} = $self{_wid} = 0; $self{_init_pid} = "$$.$_tid"; return \%self; } for my $_p (keys %self) { _croak("MCE::new: ($_p) is not a valid constructor argument") unless (exists $_valid_fields_new{$_p}); } $self{_caller} = $_pkg, $self{_init_pid} = "$$.$_tid"; if (defined $self{use_threads}) { if (!$_has_threads && $self{use_threads} ne '0') { my $_msg = "\n"; $_msg .= "## Please include threads support prior to loading MCE\n"; $_msg .= "## when specifying use_threads => $self{use_threads}\n"; $_msg .= "\n"; _croak($_msg); } } else { $self{use_threads} = ($_has_threads) ? 1 : 0; } if (!exists $self{posix_exit}) { $self{posix_exit} = 1 if ($_has_threads && $_tid); $self{posix_exit} = 1 if ($INC{'CGI.pm'} || $INC{'FCGI.pm'}); $self{posix_exit} = 1 if ($INC{'Mojo/IOLoop.pm'} || $INC{'Tk.pm'}); } $self{flush_file} ||= 0; $self{flush_stderr} ||= 0; $self{flush_stdout} ||= 0; $self{loop_timeout} ||= 0; $self{max_retries} ||= 0; $self{parallel_io} ||= 0; $self{use_slurpio} ||= 0; ## ------------------------------------------------------------------------- ## Validation. _croak("MCE::new: ($self{tmp_dir}) is not a directory or does not exist") unless (-d $self{tmp_dir}); _croak("MCE::new: ($self{tmp_dir}) is not writeable") unless (-w $self{tmp_dir}); if (defined $self{user_tasks}) { _croak('MCE::new: (user_tasks) is not an ARRAY reference') unless (ref $self{user_tasks} eq 'ARRAY'); $self{max_workers} = _parse_max_workers($self{max_workers}); $self{init_relay} = $self{user_tasks}->[0]->{init_relay} if ($self{user_tasks}->[0]->{init_relay}); for my $_task (@{ $self{user_tasks} }) { for my $_p (keys %{ $_task }) { _croak("MCE::new: ($_p) is not a valid task constructor argument") unless (exists $_valid_fields_task{$_p}); } $_task->{max_workers} = $self{max_workers} unless (defined $_task->{max_workers}); $_task->{use_threads} = $self{use_threads} unless (defined $_task->{use_threads}); bless($_task, ref(\%self) || \%self); } } _validate_args(\%self); ## ------------------------------------------------------------------------- ## Private options. Limit chunk_size. my $_run_lock; $self{_chunk_id} = 0; # Chunk ID $self{_send_cnt} = 0; # Number of times data was sent via send $self{_spawned} = 0; # Have workers been spawned $self{_task_id} = 0; # Task ID, starts at 0 (array index) $self{_task_wid} = 0; # Task Worker ID, starts at 1 per task $self{_wid} = 0; # Worker ID, starts at 1 per MCE instance $self{_wrk_status} = 0; # For saving exit status when worker exits $self{chunk_size} = MAX_CHUNK_SIZE if ($self{chunk_size} > MAX_CHUNK_SIZE); $self{_run_lock} = threads::shared::share($_run_lock) if $_is_MSWin32; $self{_last_sref} = (ref $self{input_data} eq 'SCALAR') ? refaddr($self{input_data}) : 0; my $_data_channels = ($_oid eq "$$.$_tid") ? DATA_CHANNELS : 4; my $_total_workers = 0; if (defined $self{user_tasks}) { $_total_workers += $_->{max_workers} for (@{ $self{user_tasks} }); } else { $_total_workers = $self{max_workers}; } $self{_init_total_workers} = $_total_workers; $self{_data_channels} = ($_total_workers < $_data_channels) ? $_total_workers : $_data_channels; $self{_lock_chn} = ($_total_workers > $_data_channels) ? 1 : 0; $self{_lock_chn} = 1 if ($INC{'MCE/Hobo.pm'}); $MCE = \%self if ($MCE->{_wid} == 0); return \%self; } ############################################################################### ## ---------------------------------------------------------------------------- ## Spawn method. ## ############################################################################### sub spawn { my $self = shift; $self = $MCE unless ref($self); local $_; @_ = (); _croak('MCE::spawn: method is not allowed by the worker process') if ($self->{_wid}); ## Return if workers have already been spawned or if module instance. return $self if ($self->{_spawned} || exists $self->{_module_instance}); lock $_MCE_LOCK if $_has_threads; # Obtain locks lock $_WIN_LOCK if $_is_MSWin32; ## Start the shared-manager process if present. MCE::Shared->start() if $INC{'MCE/Shared.pm'}; ## Load input module. if (defined $self->{sequence}) { require MCE::Core::Input::Sequence unless $INC{'MCE/Core/Input/Sequence.pm'}; } elsif (defined $self->{input_data}) { my $_ref = ref $self->{input_data}; if ($_ref eq 'ARRAY' || $_ref =~ /^(?:GLOB|FileHandle|IO::)/) { require MCE::Core::Input::Request unless $INC{'MCE/Core/Input/Request.pm'}; } elsif ($_ref eq 'CODE') { require MCE::Core::Input::Iterator unless $INC{'MCE/Core/Input/Iterator.pm'}; } else { require MCE::Core::Input::Handle unless $INC{'MCE/Core/Input/Handle.pm'}; } } my $_die_handler = $SIG{__DIE__}; $SIG{__DIE__} = \&_die; my $_warn_handler = $SIG{__WARN__}; $SIG{__WARN__} = \&_warn; if (!defined $TOP_HDLR || (!$TOP_HDLR->{_mgr_live} && !$TOP_HDLR->{_wid})) { ## On Windows, must shutdown the last idle MCE session. if ($_is_MSWin32 && defined $TOP_HDLR && $TOP_HDLR->{_spawned}) { $TOP_HDLR->shutdown(1); } $TOP_HDLR = $self; } elsif (refaddr($self) != refaddr($TOP_HDLR)) { ## Reduce the maximum number of channels for nested sessions. $self->{_data_channels} = 4 if ($self->{_data_channels} > 4); $self->{_lock_chn} = 1 if ($self->{_init_total_workers} > 4); ## On Windows, instruct the manager process to enable win32 IPC. if ($_is_MSWin32 && $ENV{'PERL_MCE_IPC'} ne 'win32') { $ENV{'PERL_MCE_IPC'} = 'win32'; local $\ = undef; my $_DAT_W_SOCK = $TOP_HDLR->{_dat_w_sock}->[0]; print {$_DAT_W_SOCK} OUTPUT_S_IPC.$LF . '0'.$LF; sysread $_DAT_W_SOCK, my($_buf), 1; } } ## Configure tid/sid for this instance here, not in the new method above. ## We want the actual thread id in which spawn was called under. unless ($self->{_mce_sid}) { $self->{_mce_tid} = ($_has_threads) ? threads->tid() : ''; $self->{_mce_tid} = '' unless (defined $self->{_mce_tid}); $self->{_mce_sid} = $$ .'.'. $self->{_mce_tid} .'.'. (++$_mce_count); } my $_mce_sid = $self->{_mce_sid}; my $_sess_dir = $self->{_sess_dir}; my $_tmp_dir = $self->{tmp_dir}; ## Create temp dir. unless ($_sess_dir) { _croak("MCE::spawn: ($_tmp_dir) is not defined") if (!defined $_tmp_dir || $_tmp_dir eq ''); _croak("MCE::spawn: ($_tmp_dir) is not a directory or does not exist") unless (-d $_tmp_dir); _croak("MCE::spawn: ($_tmp_dir) is not writeable") unless (-w $_tmp_dir); my $_cnt = 0; $_sess_dir = $self->{_sess_dir} = "$_tmp_dir/$_mce_sid"; $_sess_dir = $self->{_sess_dir} = "$_tmp_dir/$_mce_sid." . (++$_cnt) while ( !(mkdir $_sess_dir, 0770) ); } ## ------------------------------------------------------------------------- my $_data_channels = $self->{_data_channels}; my $_max_workers = _get_max_workers($self); my $_use_threads = $self->{use_threads}; ## Create locks for data channels. $self->{'_mutex_0'} = MCE::Mutex->new(); if ($self->{_lock_chn}) { $self->{'_mutex_'.$_} = MCE::Mutex->new() for (1 .. $_data_channels); } ## Create sockets for IPC. MCE::Util::_sock_pair($self, qw(_bsb_r_sock _bsb_w_sock)); # sync MCE::Util::_sock_pair($self, qw(_bse_r_sock _bse_w_sock)); # sync MCE::Util::_sock_pair($self, qw(_com_r_sock _com_w_sock)); # core MCE::Util::_sock_pair($self, qw(_dat_r_sock _dat_w_sock), $_) # core for (0 .. $_data_channels); setsockopt($self->{_dat_r_sock}->[0], SOL_SOCKET, SO_RCVBUF, pack('i', 4096)) if ($^O ne 'aix' && $^O ne 'linux'); ($_is_MSWin32) # input ? MCE::Util::_pipe_pair($self, qw(_que_r_sock _que_w_sock)) : MCE::Util::_sock_pair($self, qw(_que_r_sock _que_w_sock)); if (defined $self->{init_relay}) { # relay unless (defined $MCE::Relay::VERSION) { require MCE::Relay; MCE::Relay->import(); } MCE::Util::_sock_pair($self, qw(_rla_r_sock _rla_w_sock), $_) for (0 .. $_max_workers - 1); } $self->{_seed} = int(rand() * 1e9); ## ------------------------------------------------------------------------- ## Spawn workers. $self->{_pids} = [], $self->{_thrs} = [], $self->{_tids} = []; $self->{_status} = [], $self->{_state} = [], $self->{_task} = []; if (!defined $self->{user_tasks}) { $self->{_total_workers} = $_max_workers; if (defined $_use_threads && $_use_threads == 1) { _dispatch_thread($self, $_) for (1 .. $_max_workers); } else { _dispatch_child($self, $_) for (1 .. $_max_workers); } $self->{_task}->[0] = { _total_workers => $_max_workers }; for my $_i (1 .. $_max_workers) { keys(%{ $self->{_state}->[$_i] }) = 5; $self->{_state}->[$_i] = { _task => undef, _task_id => undef, _task_wid => undef, _params => undef, _chn => $_i % $_data_channels + 1 } } } else { my ($_task_id, $_wid); $self->{_total_workers} = 0; $self->{_total_workers} += $_->{max_workers} for @{ $self->{user_tasks} }; # Must spawn processes first for extra stability on BSD/Darwin. $_task_id = $_wid = 0; for my $_task (@{ $self->{user_tasks} }) { my $_tsk_use_threads = $_task->{use_threads}; if (defined $_tsk_use_threads && $_tsk_use_threads == 1) { $_wid += $_task->{max_workers}; } else { _dispatch_child($self, ++$_wid, $_task, $_task_id, $_) for (1 .. $_task->{max_workers}); } $_task_id++; } # Then, spawn threads last. $_task_id = $_wid = 0; for my $_task (@{ $self->{user_tasks} }) { my $_tsk_use_threads = $_task->{use_threads}; if (defined $_tsk_use_threads && $_tsk_use_threads == 1) { _dispatch_thread($self, ++$_wid, $_task, $_task_id, $_) for (1 .. $_task->{max_workers}); } else { $_wid += $_task->{max_workers}; } $_task_id++; } # Save state. $_task_id = $_wid = 0; for my $_task (@{ $self->{user_tasks} }) { $self->{_task}->[$_task_id] = { _total_running => 0, _total_workers => $_task->{max_workers} }; for my $_i (1 .. $_task->{max_workers}) { keys(%{ $self->{_state}->[++$_wid] }) = 5; $self->{_state}->[$_wid] = { _task => $_task, _task_id => $_task_id, _task_wid => $_i, _params => undef, _chn => $_wid % $_data_channels + 1 } } $_task_id++; } } ## ------------------------------------------------------------------------- $self->{_send_cnt} = 0, $self->{_spawned} = 1; $SIG{__DIE__} = $_die_handler; $SIG{__WARN__} = $_warn_handler; $MCE = $self if ($MCE->{_wid} == 0); return $self; } ############################################################################### ## ---------------------------------------------------------------------------- ## "for" sugar methods, process method, and relay stubs for MCE::Relay. ## ############################################################################### sub forchunk { require MCE::Candy unless (defined $MCE::Candy::VERSION); return MCE::Candy::forchunk(@_); } sub foreach { require MCE::Candy unless (defined $MCE::Candy::VERSION); return MCE::Candy::foreach(@_); } sub forseq { require MCE::Candy unless (defined $MCE::Candy::VERSION); return MCE::Candy::forseq(@_); } sub process { my $self = shift; $self = $MCE unless ref($self); _validate_runstate($self, 'MCE::process'); my ($_input_data, $_params_ref); if (ref $_[0] eq 'HASH') { $_input_data = $_[1]; $_params_ref = $_[0]; } else { $_input_data = $_[0]; $_params_ref = $_[1]; } @_ = (); ## Set input data. if (defined $_input_data) { $_params_ref->{input_data} = $_input_data; } elsif ( !defined $_params_ref->{input_data} && !defined $_params_ref->{sequence} ) { _croak('MCE::process: (input_data or sequence) is not specified'); } ## Pass 0 to "not" auto-shutdown after processing. $self->run(0, $_params_ref); return $self; } sub relay_final {} sub relay_recv { _croak('MCE::relay: (init_relay) is not specified') unless (defined $MCE->{init_relay}); } sub relay (;&) { _croak('MCE::relay: (init_relay) is not specified') unless (defined $MCE->{init_relay}); } *relay_lock = \&relay_recv; *relay_unlock = \&relay; ############################################################################### ## ---------------------------------------------------------------------------- ## Restart worker method. ## ############################################################################### sub restart_worker { my $self = shift; $self = $MCE unless ref($self); @_ = (); _croak('MCE::restart_worker: method is not allowed by the worker process') if ($self->{_wid}); my $_wid = $self->{_exited_wid}; my $_params = $self->{_state}->[$_wid]->{_params}; my $_task_wid = $self->{_state}->[$_wid]->{_task_wid}; my $_task_id = $self->{_state}->[$_wid]->{_task_id}; my $_task = $self->{_state}->[$_wid]->{_task}; my $_chn = $self->{_state}->[$_wid]->{_chn}; $_params->{_chn} = $_chn; my $_use_threads = (defined $_task_id) ? $_task->{use_threads} : $self->{use_threads}; $self->{_task}->[$_task_id]->{_total_running} += 1 if (defined $_task_id); $self->{_task}->[$_task_id]->{_total_workers} += 1 if (defined $_task_id); $self->{_total_running} += 1; $self->{_total_workers} += 1; if (defined $_use_threads && $_use_threads == 1) { _dispatch_thread($self, $_wid, $_task, $_task_id, $_task_wid, $_params); } else { _dispatch_child($self, $_wid, $_task, $_task_id, $_task_wid, $_params); } return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Run method. ## ############################################################################### sub run { my $self = shift; $self = $MCE unless ref($self); _croak('MCE::run: method is not allowed by the worker process') if ($self->{_wid}); my ($_auto_shutdown, $_params_ref); if (ref $_[0] eq 'HASH') { $_auto_shutdown = (defined $_[1]) ? $_[1] : 1; $_params_ref = $_[0]; } else { $_auto_shutdown = (defined $_[0]) ? $_[0] : 1; $_params_ref = $_[1]; } @_ = (); my $_has_user_tasks = (defined $self->{user_tasks}) ? 1 : 0; my $_requires_shutdown = 0; ## Unset params if workers have already been sent user_data via send. ## Set user_func to NOOP if not specified. $_params_ref = undef if ($self->{_send_cnt}); if (!defined $self->{user_func} && !defined $_params_ref->{user_func}) { $self->{user_func} = \&_NOOP; } ## Set user specified params if specified. ## Shutdown workers if determined by _sync_params or if processing a ## scalar reference. Workers need to be restarted in order to pick up ## on the new code or scalar reference. if (defined $_params_ref && ref $_params_ref eq 'HASH') { $_requires_shutdown = _sync_params($self, $_params_ref); _validate_args($self); } if ($_has_user_tasks) { $self->{input_data} = $self->{user_tasks}->[0]->{input_data} if ($self->{user_tasks}->[0]->{input_data}); $self->{use_slurpio} = $self->{user_tasks}->[0]->{use_slurpio} if ($self->{user_tasks}->[0]->{use_slurpio}); $self->{parallel_io} = $self->{user_tasks}->[0]->{parallel_io} if ($self->{user_tasks}->[0]->{parallel_io}); $self->{RS} = $self->{user_tasks}->[0]->{RS} if ($self->{user_tasks}->[0]->{RS}); } if (ref $self->{input_data} eq 'SCALAR') { if (refaddr($self->{input_data}) != $self->{_last_sref}) { $_requires_shutdown = 1; } $self->{_last_sref} = refaddr($self->{input_data}); } $self->shutdown() if ($_requires_shutdown); ## ------------------------------------------------------------------------- $self->{_wrk_status} = 0; ## Spawn workers. $self->spawn() unless ($self->{_spawned}); return $self unless ($self->{_total_workers}); local $SIG{__DIE__} = \&_die; local $SIG{__WARN__} = \&_warn; $MCE = $self if ($MCE->{_wid} == 0); my ($_input_data, $_input_file, $_input_glob, $_seq); my ($_abort_msg, $_first_msg, $_run_mode, $_single_dim); my $_chunk_size = $self->{chunk_size}; $_seq = ($_has_user_tasks && $self->{user_tasks}->[0]->{sequence}) ? $self->{user_tasks}->[0]->{sequence} : $self->{sequence}; ## Determine run mode for workers. if (defined $_seq) { my ($_begin, $_end, $_step, $_fmt) = (ref $_seq eq 'ARRAY') ? @{ $_seq } : ($_seq->{begin}, $_seq->{end}, $_seq->{step}); $_chunk_size = $self->{user_tasks}->[0]->{chunk_size} if ($_has_user_tasks && $self->{user_tasks}->[0]->{chunk_size}); $_run_mode = 'sequence'; $_abort_msg = int(($_end - $_begin) / $_step / $_chunk_size) + 1; $_first_msg = 0; } elsif (defined $self->{input_data}) { my $_ref = ref $self->{input_data}; if ($_ref eq 'ARRAY') { # Array mode $_run_mode = 'array'; $_input_data = $self->{input_data}; $_input_file = $_input_glob = undef; $_single_dim = 1 if (ref $_input_data->[0] eq ''); $_abort_msg = 0; ## Flag: Has Data: No $_first_msg = 1; ## Flag: Has Data: Yes if (@{ $_input_data } == 0) { return $self->shutdown() if ($_auto_shutdown == 1); } } elsif ($_ref =~ /^(?:GLOB|FileHandle|IO::)/) { # Glob mode $_run_mode = 'glob'; $_input_glob = $self->{input_data}; $_input_data = $_input_file = undef; $_abort_msg = 0; ## Flag: Has Data: No $_first_msg = 1; ## Flag: Has Data: Yes } elsif ($_ref eq 'CODE') { # Iterator mode $_run_mode = 'iterator'; $_input_data = $self->{input_data}; $_input_file = $_input_glob = undef; $_abort_msg = 0; ## Flag: Has Data: No $_first_msg = 1; ## Flag: Has Data: Yes } elsif ($_ref eq '') { # File mode $_run_mode = 'file'; $_input_file = $self->{input_data}; $_input_data = $_input_glob = undef; $_abort_msg = (-s $_input_file) + 1; $_first_msg = 0; ## Begin at offset position if ((-s $_input_file) == 0) { return $self->shutdown() if ($_auto_shutdown == 1); } } elsif ($_ref eq 'SCALAR') { # Memory mode $_run_mode = 'memory'; $_input_data = $_input_file = $_input_glob = undef; $_abort_msg = length(${ $self->{input_data} }) + 1; $_first_msg = 0; ## Begin at offset position if (length(${ $self->{input_data} }) == 0) { return $self->shutdown() if ($_auto_shutdown == 1); } } else { _croak('MCE::run: (input_data) is not valid'); } } else { # Nodata mode $_abort_msg = undef, $_run_mode = 'nodata'; } ## ------------------------------------------------------------------------- my $_total_workers = $self->{_total_workers}; my $_send_cnt = $self->{_send_cnt}; if ($_send_cnt) { $self->{_total_running} = $_send_cnt; $self->{_task}->[0]->{_total_running} = $_send_cnt; } else { $self->{_total_running} = $_total_workers; my ($_frozen_nodata, $_wid, %_params_nodata, %_task0_wids); my $_COM_R_SOCK = $self->{_com_r_sock}; my $_submit_delay = $self->{submit_delay}; my %_params = ( '_abort_msg' => $_abort_msg, '_run_mode' => $_run_mode, '_input_file' => $_input_file, '_chunk_size' => $_chunk_size, '_single_dim' => $_single_dim, '_bounds_only' => $self->{bounds_only}, '_interval' => $self->{interval}, '_max_retries' => $self->{max_retries}, '_parallel_io' => $self->{parallel_io}, '_sequence' => $self->{sequence}, '_user_args' => $self->{user_args}, '_use_slurpio' => $self->{use_slurpio}, '_RS' => $self->{RS} ); my $_frozen_params = $self->{freeze}(\%_params); $_frozen_params = length($_frozen_params).$LF . $_frozen_params; if ($_has_user_tasks) { %_params_nodata = ( %_params, '_abort_msg' => undef, '_run_mode' => 'nodata' ); $_frozen_nodata = $self->{freeze}(\%_params_nodata); $_frozen_nodata = length($_frozen_nodata).$LF . $_frozen_nodata; for my $_t (@{ $self->{_task} }) { $_t->{_total_running} = $_t->{_total_workers}; } for my $_i (1 .. @{ $self->{_state} } - 1) { $_task0_wids{$_i} = 1 unless ($self->{_state}[$_i]{_task_id}); } } local $\ = undef; local $/ = $LF; ## Insert the first message into the queue if defined. if (defined $_first_msg) { my $_QUE_W_SOCK = $self->{_que_w_sock}; syswrite $_QUE_W_SOCK, pack($_que_template, 0, $_first_msg); } ## Submit params data to workers. for my $_i (1 .. $_total_workers) { print {$_COM_R_SOCK} $_i.$LF; chomp($_wid = <$_COM_R_SOCK>); if (!$_has_user_tasks || exists $_task0_wids{$_wid}) { print {$_COM_R_SOCK} $_frozen_params; $self->{_state}[$_wid]{_params} = \%_params; } else { print {$_COM_R_SOCK} $_frozen_nodata; $self->{_state}[$_wid]{_params} = \%_params_nodata; } <$_COM_R_SOCK>; if (defined $_submit_delay && $_submit_delay > 0.0) { sleep $_submit_delay; } } } ## ------------------------------------------------------------------------- $self->{_total_exited} = 0; ## Call the output function. if ($self->{_total_running} > 0) { $self->{_mgr_live} = 1; $self->{_abort_msg} = $_abort_msg; $self->{_single_dim} = $_single_dim; lock $self->{_run_lock} if $_is_MSWin32; if (!$_send_cnt) { ## Notify workers to commence processing. if ($_is_MSWin32) { my $_buf = sprintf("%${_total_workers}s", ""); syswrite $self->{_bse_w_sock}, $_buf; } else { my $_BSE_W_SOCK = $self->{_bse_w_sock}; for my $_i (1 .. $_total_workers) { syswrite $_BSE_W_SOCK, $LF; } } } _output_loop( $self, $_input_data, $_input_glob, \%_plugin_function, \@_plugin_loop_begin, \@_plugin_loop_end ); $self->{_mgr_live} = $self->{_abort_msg} = $self->{_single_dim} = undef; } ## Remove the last message from the queue. if (!$_send_cnt && $_run_mode ne 'nodata') { if (defined $self->{_que_r_sock}) { my $_QUE_R_SOCK = $self->{_que_r_sock}; sysread $_QUE_R_SOCK, my($_next), $_que_read_size; } } $self->{_send_cnt} = 0; ## Shutdown workers. if ( $_auto_shutdown || $self->{_total_exited} ) { $self->shutdown(); } elsif ($^S || $ENV{'PERL_IPERL_RUNNING'}) { if (!$INC{'Mojo/IOLoop.pm'} && !$INC{'Tk.pm'}) { # running inside eval or IPerl, check stack trace my $_t = Carp::longmess(); $_t =~ s/\teval [^\n]+\n$//; if ( $_t =~ /^(?:[^\n]+\n){1,7}\teval / || $_t =~ /\n\teval [^\n]+\n\t(?:eval|Try)/ || $_t =~ /\n\tMCE::_dispatch\(\) [^\n]+ thread \d+\n$/ || ( $_tid && !$self->{use_threads} ) ) { $self->shutdown(); } } } return $self; } ############################################################################### ## ---------------------------------------------------------------------------- ## Send method. ## ############################################################################### sub send { my $self = shift; $self = $MCE unless ref($self); _croak('MCE::send: method is not allowed by the worker process') if ($self->{_wid}); _croak('MCE::send: method is not allowed while running') if ($self->{_total_running}); _croak('MCE::send: method cannot be used with input_data or sequence') if (defined $self->{input_data} || defined $self->{sequence}); _croak('MCE::send: method cannot be used with user_tasks') if (defined $self->{user_tasks}); my $_data_ref; if (ref $_[0] eq 'ARRAY' || ref $_[0] eq 'HASH' || ref $_[0] eq 'PDL') { $_data_ref = $_[0]; } else { _croak('MCE::send: ARRAY, HASH, or a PDL reference is not specified'); } @_ = (); $self->{_send_cnt} = 0 unless (defined $self->{_send_cnt}); ## ------------------------------------------------------------------------- ## Spawn workers. $self->spawn() unless ($self->{_spawned}); _croak('MCE::send: Sending greater than # of workers is not allowed') if ($self->{_send_cnt} >= $self->{_task}->[0]->{_total_workers}); local $SIG{__DIE__} = \&_die; local $SIG{__WARN__} = \&_warn; ## Begin data submission. local $\ = undef; local $/ = $LF; my $_COM_R_SOCK = $self->{_com_r_sock}; my $_sess_dir = $self->{_sess_dir}; my $_submit_delay = $self->{submit_delay}; my $_frozen_data = $self->{freeze}($_data_ref); my $_len = length $_frozen_data; ## Submit data to worker. print {$_COM_R_SOCK} '_data'.$LF; <$_COM_R_SOCK>; print {$_COM_R_SOCK} $_len.$LF, $_frozen_data; <$_COM_R_SOCK>; if (defined $_submit_delay && $_submit_delay > 0.0) { sleep $_submit_delay; } $self->{_send_cnt} += 1; return $self; } ############################################################################### ## ---------------------------------------------------------------------------- ## Shutdown method. ## ############################################################################### sub shutdown { my $self = shift; $self = $MCE unless ref($self); my $_no_lock = shift || 0; @_ = (); ## Return if workers have not been spawned or have already been shutdown. return unless ($self->{_spawned}); return unless (defined $MCE::Signal::tmp_dir); _validate_runstate($self, 'MCE::shutdown'); ## Wait for workers to complete processing before shutting down. $self->run(0) if ($self->{_send_cnt}); local $SIG{__DIE__} = \&_die; local $SIG{__WARN__} = \&_warn; my $_COM_R_SOCK = $self->{_com_r_sock}; my $_data_channels = $self->{_data_channels}; my $_total_workers = $self->{_total_workers}; my $_sess_dir = $self->{_sess_dir}; my $_mce_sid = $self->{_mce_sid}; if (defined $TOP_HDLR && refaddr($self) == refaddr($TOP_HDLR)) { $TOP_HDLR = undef; } ## ------------------------------------------------------------------------- lock $_MCE_LOCK if ($_has_threads && $_is_winenv && !$_no_lock); ## Notify workers to exit loop. local ($!, $?, $_); local $\ = undef; local $/ = $LF; for (1 .. $_total_workers) { print {$_COM_R_SOCK} '_exit'.$LF; <$_COM_R_SOCK>; } ## Reap children and/or threads. if (@{ $self->{_pids} } > 0) { my $_list = $self->{_pids}; for my $i (0 .. @{ $_list }) { waitpid($_list->[$i], 0) if $_list->[$i]; } } if (@{ $self->{_thrs} } > 0) { my $_list = $self->{_thrs}; for my $i (0 .. @{ $_list }) { $_list->[$i]->join() if $_list->[$i]; } } ## Close sockets. $_COM_R_SOCK = undef; MCE::Util::_destroy_socks($self, qw( _bsb_w_sock _bsb_r_sock _bse_w_sock _bse_r_sock _com_w_sock _com_r_sock _dat_w_sock _dat_r_sock _rla_w_sock _rla_r_sock )); ($_is_MSWin32) ? MCE::Util::_destroy_pipes($self, qw( _que_w_sock _que_r_sock )) : MCE::Util::_destroy_socks($self, qw( _que_w_sock _que_r_sock )); ## ------------------------------------------------------------------------- ## Destroy locks. Remove the session directory afterwards. if (defined $_sess_dir) { $self->{_mutex_0}->DESTROY('shutdown') if (defined $self->{_mutex_0}); if ($self->{_lock_chn}) { for my $_i (1 .. $_data_channels) { $self->{'_mutex_'.$_i}->DESTROY('shutdown') if (defined $self->{'_mutex_'.$_i}); } } rmdir "$_sess_dir"; } ## Reset instance. undef @{$self->{_pids}}; undef @{$self->{_thrs}}; undef @{$self->{_tids}}; undef @{$self->{_state}}; undef @{$self->{_status}}; undef @{$self->{_task}}; $self->{_mce_sid} = $self->{_mce_tid} = $self->{_sess_dir} = undef; $self->{_chunk_id} = $self->{_send_cnt} = $self->{_spawned} = 0; $self->{_total_running} = $self->{_total_exited} = 0; $self->{_total_workers} = 0; return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Barrier sync and yield methods. ## ############################################################################### sub sync { my $self = shift; $self = $MCE unless ref($self); return unless ($self->{_wid}); ## Barrier synchronization is supported for task 0 at this time. ## Note: Workers are assigned task_id 0 when omitting user_tasks. return if ($self->{_task_id} > 0); my $_chn = $self->{_chn}; my $_DAT_W_SOCK = $self->{_dat_w_sock}->[0]; my $_BSB_R_SOCK = $self->{_bsb_r_sock}; my $_BSE_R_SOCK = $self->{_bse_r_sock}; my $_buf; local $\ = undef if (defined $\); ## Notify the manager process (barrier begin). print {$_DAT_W_SOCK} OUTPUT_B_SYN.$LF . $_chn.$LF; ## Wait until all workers from (task_id 0) have synced. MCE::Util::_sock_ready($_BSB_R_SOCK) if $_is_MSWin32; sysread $_BSB_R_SOCK, $_buf, 1; ## Notify the manager process (barrier end). print {$_DAT_W_SOCK} OUTPUT_E_SYN.$LF . $_chn.$LF; ## Wait until all workers from (task_id 0) have un-synced. sysread $_BSE_R_SOCK, $_buf, 1; return; } sub yield { my $self = shift; $self = $MCE unless ref($self); return unless ($self->{_i_wrk_st}); return unless ($self->{_task_wid}); my $_delay = $self->{_i_wrk_st} - time; my $_count; if ($_delay < 0.0) { $_count = int($_delay * -1 / $self->{_i_app_tb} + 0.5) + 1; $_delay += $self->{_i_app_tb} * $_count; } sleep $_delay if ($_delay > 0.0); if ($_count && $_count > 2e9) { $self->{_i_wrk_st} = time; } return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Miscellaneous methods: abort exit last next pid status. ## ############################################################################### ## Abort current job. sub abort { my $self = shift; $self = $MCE unless ref($self); my $_QUE_R_SOCK = $self->{_que_r_sock}; my $_QUE_W_SOCK = $self->{_que_w_sock}; my $_abort_msg = $self->{_abort_msg}; if (defined $_abort_msg) { local $\ = undef; if ($_abort_msg > 0) { sysread $_QUE_R_SOCK, my($_next), $_que_read_size; syswrite $_QUE_W_SOCK, pack($_que_template, 0, $_abort_msg); } if ($self->{_wid} > 0) { my $_chn = $self->{_chn}; my $_DAT_LOCK = $self->{_dat_lock}; my $_DAT_W_SOCK = $self->{_dat_w_sock}->[0]; my $_DAU_W_SOCK = $self->{_dat_w_sock}->[$_chn]; my $_lock_chn = $self->{_lock_chn}; $_DAT_LOCK->lock() if $_lock_chn; print {$_DAT_W_SOCK} OUTPUT_W_ABT.$LF . $_chn.$LF; $_DAT_LOCK->unlock() if $_lock_chn; } } return; } ## Worker exits from MCE. sub exit { my $self = shift; $self = $MCE unless ref($self); my $_exit_status = (defined $_[0]) ? $_[0] : $?; my $_exit_msg = (defined $_[1]) ? $_[1] : ''; my $_exit_id = (defined $_[2]) ? $_[2] : ''; @_ = (); _croak('MCE::exit: method is not allowed by the manager process') unless ($self->{_wid}); my $_chn = $self->{_chn}; my $_DAT_LOCK = $self->{_dat_lock}; my $_DAT_W_SOCK = $self->{_dat_w_sock}->[0]; my $_DAU_W_SOCK = $self->{_dat_w_sock}->[$_chn]; my $_lock_chn = $self->{_lock_chn}; my $_task_id = $self->{_task_id}; my $_sess_dir = $self->{_sess_dir}; unless ($self->{_exiting}) { $self->{_exiting} = 1; local $\ = undef if (defined $\); my $_len = length $_exit_msg; $_exit_id =~ s/[\r\n][\r\n]*/ /mg; $_DAT_LOCK->lock() if $_lock_chn; print {$_DAT_W_SOCK} OUTPUT_W_EXT.$LF . $_chn.$LF; print {$_DAU_W_SOCK} $_task_id.$LF . $self->{_wid}.$LF . $self->{_exit_pid}.$LF . $_exit_status.$LF . $_exit_id.$LF . $_len.$LF . $_exit_msg ; if ($self->{_retry} && $self->{_retry}->[2]--) { my $_buf = $self->{freeze}($self->{_retry}); print {$_DAU_W_SOCK} length($_buf).$LF, $_buf; } else { print {$_DAU_W_SOCK} '0'.$LF; } $_DAT_LOCK->unlock() if $_lock_chn; } _exit($self); } ## Worker immediately exits the chunking loop. sub last { my $self = shift; $self = $MCE unless ref($self); _croak('MCE::last: method is not allowed by the manager process') unless ($self->{_wid}); $self->{_last_jmp}() if (defined $self->{_last_jmp}); return; } ## Worker starts the next iteration of the chunking loop. sub next { my $self = shift; $self = $MCE unless ref($self); _croak('MCE::next: method is not allowed by the manager process') unless ($self->{_wid}); $self->{_next_jmp}() if (defined $self->{_next_jmp}); return; } ## Return the process ID. Attach the thread ID for threads. sub pid { my $self = shift; $self = $MCE unless ref($self); if (defined $self->{_pid}) { $self->{_pid}; } elsif ($_has_threads && $self->{use_threads}) { $$ .'.'. threads->tid(); } else { $$; } } ## Return the exit status. "_wrk_status" holds the greatest exit status ## among workers exiting. sub status { my $self = shift; $self = $MCE unless ref($self); _croak('MCE::status: method is not allowed by the worker process') if ($self->{_wid}); return (defined $self->{_wrk_status}) ? $self->{_wrk_status} : 0; } ############################################################################### ## ---------------------------------------------------------------------------- ## Methods for serializing data from workers to the main process. ## ############################################################################### ## Do method. Additional arguments are optional. sub do { my $self = shift; $self = $MCE unless ref($self); my $_pkg = caller() eq 'MCE' ? caller(1) : caller(); _croak('MCE::do: method is not allowed by the manager process') unless ($self->{_wid}); if (ref $_[0] eq 'CODE') { _croak('MCE::do: (code ref) is not supported'); } else { _croak('MCE::do: (callback) is not specified') unless (defined ( my $_func = shift )); $_func = $_pkg.'::'.$_func if (index($_func, ':') < 0); return _do_callback($self, $_func, [ @_ ]); } } ## Gather method. sub gather { my $self = shift; $self = $MCE unless ref($self); _croak('MCE::gather: method is not allowed by the manager process') unless ($self->{_wid}); return _do_gather($self, [ @_ ]); } ## Sendto method. { my %_sendto_lkup = ( 'file' => SENDTO_FILEV1, 'FILE' => SENDTO_FILEV1, 'file:' => SENDTO_FILEV2, 'FILE:' => SENDTO_FILEV2, 'stdout' => SENDTO_STDOUT, 'STDOUT' => SENDTO_STDOUT, 'stderr' => SENDTO_STDERR, 'STDERR' => SENDTO_STDERR, 'fd:' => SENDTO_FD, 'FD:' => SENDTO_FD, ); my $_v2_regx = qr/^([^:]+:)(.+)/; sub sendto { my $self = shift; $self = $MCE unless ref($self); my $_to = shift; _croak('MCE::sendto: method is not allowed by the manager process') unless ($self->{_wid}); return unless (defined $_[0]); my ($_dest, $_value); $_dest = (exists $_sendto_lkup{$_to}) ? $_sendto_lkup{$_to} : undef; if (!defined $_dest) { if (ref $_to && defined (my $_fd = fileno($_to))) { if (my $_ob = tied *{ $_to }) { if (ref $_ob eq 'IO::TieCombine::Handle') { $_fd = 1 if (lc($_ob->{slot_name}) eq 'stdout'); $_fd = 2 if (lc($_ob->{slot_name}) eq 'stderr'); } } my $_data_ref = (scalar @_ == 1) ? \$_[0] : \join('', @_); return _do_send_glob($self, $_to, $_fd, $_data_ref); } if (defined $_to && $_to =~ /$_v2_regx/o) { $_dest = (exists $_sendto_lkup{$1}) ? $_sendto_lkup{$1} : undef; $_value = $2; } if (!defined $_dest || ( !defined $_value && ( $_dest == SENDTO_FILEV2 || $_dest == SENDTO_FD ))) { my $_msg = "\n"; $_msg .= "MCE::sendto: improper use of method\n"; $_msg .= "\n"; $_msg .= "## usage:\n"; $_msg .= "## ->sendto(\"stderr\", ...);\n"; $_msg .= "## ->sendto(\"stdout\", ...);\n"; $_msg .= "## ->sendto(\"file:/path/to/file\", ...);\n"; $_msg .= "## ->sendto(\"fd:2\", ...);\n"; $_msg .= "\n"; _croak($_msg); } } if ($_dest == SENDTO_FILEV1) { # sendto 'file', $a, $path return if (!defined $_[1] || @_ > 2); # Please switch to using V2 $_value = $_[1]; delete $_[1]; # sendto 'file:/path', $a $_dest = SENDTO_FILEV2; } return _do_send($self, $_dest, $_value, @_); } } ############################################################################### ## ---------------------------------------------------------------------------- ## Functions for serializing print, printf and say statements. ## ############################################################################### sub print { my $self = shift; $self = $MCE unless ref($self); my ($_fd, $_glob, $_data_ref); if (ref $_[0] && defined ($_fd = fileno($_[0]))) { if (my $_ob = tied *{ $_[0] }) { if (ref $_ob eq 'IO::TieCombine::Handle') { $_fd = 1 if (lc($_ob->{slot_name}) eq 'stdout'); $_fd = 2 if (lc($_ob->{slot_name}) eq 'stderr'); } } $_glob = shift; } if (scalar @_ == 1 ) { $_data_ref = \$_[0]; } elsif (scalar @_ > 1) { $_data_ref = \join('', @_); } else { $_data_ref = \$_; } return _do_send_glob($self, $_glob, $_fd, $_data_ref) if $_fd; return _do_send($self, SENDTO_STDOUT, undef, $_data_ref) if $self->{_wid}; return _do_send_glob($self, \*STDOUT, 1, $_data_ref); } sub printf { my $self = shift; $self = $MCE unless ref($self); my ($_fd, $_glob, $_fmt, $_data); if (ref $_[0] && defined ($_fd = fileno($_[0]))) { if (my $_ob = tied *{ $_[0] }) { if (ref $_ob eq 'IO::TieCombine::Handle') { $_fd = 1 if (lc($_ob->{slot_name}) eq 'stdout'); $_fd = 2 if (lc($_ob->{slot_name}) eq 'stderr'); } } $_glob = shift; } $_fmt = shift || '%s'; $_data = (scalar @_) ? sprintf($_fmt, @_) : sprintf($_fmt, $_); return _do_send_glob($self, $_glob, $_fd, \$_data) if $_fd; return _do_send($self, SENDTO_STDOUT, undef, \$_data) if $self->{_wid}; return _do_send_glob($self, \*STDOUT, 1, \$_data); } sub say { my $self = shift; $self = $MCE unless ref($self); my ($_fd, $_glob, $_data); if (ref $_[0] && defined ($_fd = fileno($_[0]))) { if (my $_ob = tied *{ $_[0] }) { if (ref $_ob eq 'IO::TieCombine::Handle') { $_fd = 1 if (lc($_ob->{slot_name}) eq 'stdout'); $_fd = 2 if (lc($_ob->{slot_name}) eq 'stderr'); } } $_glob = shift; } $_data = (scalar @_) ? join('', @_) . "\n" : $_ . "\n"; return _do_send_glob($self, $_glob, $_fd, \$_data) if $_fd; return _do_send($self, SENDTO_STDOUT, undef, \$_data) if $self->{_wid}; return _do_send_glob($self, \*STDOUT, 1, \$_data); } ############################################################################### ## ---------------------------------------------------------------------------- ## Private methods. ## ############################################################################### sub _die { return MCE::Signal->_die_handler(@_); } sub _warn { return MCE::Signal->_warn_handler(@_); } sub _NOOP {} sub _croak { if (MCE->wid == 0 || ! $^S) { $SIG{__DIE__} = \&MCE::_die; $SIG{__WARN__} = \&MCE::_warn; } $\ = undef; goto &Carp::croak; } sub _exit { my $self = shift; ## Exit thread/child process. $SIG{__DIE__} = sub { } unless $_tid; $SIG{__WARN__} = sub { }; if ($self->{use_threads}) { threads->exit(0); } elsif ($self->{posix_exit} && !$_is_MSWin32) { CORE::kill('KILL', $$); } CORE::exit(0); } sub _get_max_workers { my $self = shift; $self = $MCE unless ref($self); if (defined $self->{user_tasks}) { if (defined $self->{user_tasks}->[0]->{max_workers}) { return $self->{user_tasks}->[0]->{max_workers}; } } return $self->{max_workers}; } sub _sync_buffer_to_array { my ($_buffer_ref, $_array_ref, $_chop_str) = @_; local $_; my $_cnt = 0; open my $_MEM_FH, '<', $_buffer_ref; binmode $_MEM_FH, ':raw'; unless (length $_chop_str) { $_array_ref->[$_cnt++] = $_ while (<$_MEM_FH>); } else { $_array_ref->[$_cnt++] = <$_MEM_FH>; while (<$_MEM_FH>) { $_array_ref->[$_cnt ] = $_chop_str; $_array_ref->[$_cnt++] .= $_; } } close $_MEM_FH; weaken $_MEM_FH; return; } sub _sync_params { my ($self, $_params_ref) = @_; my $_requires_shutdown = 0; if (defined $_params_ref->{init_relay} && !defined $self->{init_relay}) { $_requires_shutdown = 1; } for my $_p (qw( user_begin user_func user_end )) { if (defined $_params_ref->{$_p}) { $self->{$_p} = delete $_params_ref->{$_p}; $_requires_shutdown = 1; } } for my $_p (keys %{ $_params_ref }) { _croak("MCE::_sync_params: ($_p) is not a valid params argument") unless (exists $_params_allowed_args{$_p}); $self->{$_p} = $_params_ref->{$_p}; } return ($self->{_spawned}) ? $_requires_shutdown : 0; } ############################################################################### ## ---------------------------------------------------------------------------- ## Dispatch methods. ## ############################################################################### sub _dispatch { my @_args = @_; my $_is_thread = shift @_args; my $self = $MCE = $_args[0]; ## To avoid (Scalars leaked: N) messages; fixed in Perl 5.12.x @_ = (); $ENV{'PERL_MCE_IPC'} = 'win32' if ($_is_MSWin32 && $INC{'MCE/Hobo.pm'}); ## Sets the seed of the base generator uniquely between workers. ## The new seed is computed using the current seed and $_wid value. ## One may set the seed at the application level for predictable ## results (non-thread workers only). Ditto for Math::Random. if (!$self->{use_threads}) { my ($_wid, $_seed) = ($_args[1], $self->{_seed}); srand(abs($_seed - ($_wid * 100000)) % 2147483560); } if ($INC{'Math/Random.pm'} && !$self->{use_threads}) { my ($_wid, $_cur_seed) = ($_args[1], Math::Random::random_get_seed()); my $_new_seed = ($_cur_seed < 1073741781) ? $_cur_seed + ($_wid * 100000) : $_cur_seed - ($_wid * 100000); Math::Random::random_set_seed($_new_seed, $_new_seed); } ## Run. $self->{_pid} = ($_is_thread) ? $$ .'.'. threads->tid() : $$; _worker_main(@_args, \@_plugin_worker_init); _exit($self); } sub _dispatch_thread { my ($self, $_wid, $_task, $_task_id, $_task_wid, $_params) = @_; @_ = (); local $_; my $_thr = threads->create( \&_dispatch, 1, $self, $_wid, $_task, $_task_id, $_task_wid, $_params ); _croak("MCE::_dispatch_thread: Failed to spawn worker $_wid: $!") if (!defined $_thr); ## Store into an available slot (restart), otherwise append to arrays. if (defined $_params) { for my $_i (0 .. @{ $self->{_tids} } - 1) { unless (defined $self->{_tids}->[$_i]) { $self->{_thrs}->[$_i] = $_thr; $self->{_tids}->[$_i] = $_thr->tid(); return; } }} push @{ $self->{_thrs} }, $_thr; push @{ $self->{_tids} }, $_thr->tid(); if (defined $self->{spawn_delay} && $self->{spawn_delay} > 0.0) { sleep $self->{spawn_delay}; } return; } sub _dispatch_child { my ($self, $_wid, $_task, $_task_id, $_task_wid, $_params) = @_; @_ = (); local $_; my $_pid = fork(); _croak("MCE::_dispatch_child: Failed to spawn worker $_wid: $!") if (!defined $_pid); _dispatch(0, $self, $_wid, $_task, $_task_id, $_task_wid, $_params) if ($_pid == 0); ## Store into an available slot (restart), otherwise append to array. if (defined $_params) { for my $_i (0 .. @{ $self->{_pids} } - 1) { unless (defined $self->{_pids}->[$_i]) { $self->{_pids}->[$_i] = $_pid; return; } }} push @{ $self->{_pids} }, $_pid; if (defined $self->{spawn_delay} && $self->{spawn_delay} > 0.0) { sleep $self->{spawn_delay}; } return; } 1; MCE-1.810/lib/MCE/0000755000175000017500000000000013022753214012300 5ustar mariomarioMCE-1.810/lib/MCE/Relay.pm0000644000175000017500000005703713022712414013723 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## Extends Many-Core Engine with relay capabilities. ## ############################################################################### package MCE::Relay; use strict; use warnings; no warnings qw( threads recursion uninitialized ); our $VERSION = '1.810'; ## no critic (Subroutines::ProhibitSubroutinePrototypes) use bytes; use constant { OUTPUT_W_RLA => 'W~RLA', # Worker has relayed }; ############################################################################### ## ---------------------------------------------------------------------------- ## Import routine. ## ############################################################################### my $LF = "\012"; Internals::SvREADONLY($LF, 1); my $_imported; sub import { my $_class = shift; return if ($_imported++); if (defined $MCE::VERSION) { _mce_m_init(); } else { $\ = undef; require Carp; Carp::croak( "MCE::Relay cannot be used directly. Please consult the MCE::Relay\n". "documentation for more information.\n\n" ); } return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Output routines for the manager process. ## ############################################################################### { my ($_MCE, $_DAU_R_SOCK_REF, $_DAU_R_SOCK, $_rla_nextid, $_max_workers); my %_output_function = ( OUTPUT_W_RLA.$LF => sub { # Worker has relayed # $_DAU_R_SOCK = ${ $_DAU_R_SOCK_REF }; $_rla_nextid = 0 if ( ++$_rla_nextid == $_max_workers ); return; }, ); sub _mce_m_loop_begin { ($_MCE, $_DAU_R_SOCK_REF) = @_; my $_caller = $_MCE->{_caller}; $_max_workers = (exists $_MCE->{user_tasks}) ? $_MCE->{user_tasks}[0]{max_workers} : $_MCE->{max_workers}; ## Write initial relay data. if (defined $_MCE->{init_relay}) { my $_ref = ref $_MCE->{init_relay}; MCE::_croak("MCE::Relay: (init_relay) is not valid") if ($_ref ne '' && $_ref ne 'HASH' && $_ref ne 'ARRAY'); my $_RLA_W_SOCK = $_MCE->{_rla_w_sock}->[0]; my $_init_relay; if (ref $_MCE->{init_relay} eq '') { $_init_relay = $_MCE->{init_relay} . '0'; } elsif (ref $_MCE->{init_relay} eq 'HASH') { $_init_relay = $_MCE->{freeze}($_MCE->{init_relay}) . '1'; } elsif (ref $_MCE->{init_relay} eq 'ARRAY') { $_init_relay = $_MCE->{freeze}($_MCE->{init_relay}) . '2'; } print {$_RLA_W_SOCK} length($_init_relay) . $LF . $_init_relay; $_rla_nextid = 0; } delete $MCE::RLA->{$_caller}; return; } sub _mce_m_loop_end { ## Obtain final relay data. if (defined $_MCE->{init_relay}) { my $_RLA_R_SOCK = $_MCE->{_rla_r_sock}->[$_rla_nextid]; my ($_caller, $_len, $_ret) = ($_MCE->{_caller}); chomp($_len = <$_RLA_R_SOCK>); read $_RLA_R_SOCK, $_ret, $_len; if (chop $_ret) { $MCE::RLA->{$_caller} = $_MCE->{thaw}($_ret); } else { $MCE::RLA->{$_caller} = $_ret; } } ## Clear variables. $_MCE = $_DAU_R_SOCK_REF = $_DAU_R_SOCK = undef; $_rla_nextid = $_max_workers = undef; return; } sub _mce_m_init { MCE::_attach_plugin( \%_output_function, \&_mce_m_loop_begin, \&_mce_m_loop_end ); return; } } ############################################################################### ## ---------------------------------------------------------------------------- ## Relay methods. ## ############################################################################### ## Items below are folded into MCE. package # hide from rpm MCE; no warnings 'threads'; no warnings 'recursion'; no warnings 'uninitialized'; use Scalar::Util qw( weaken ); use bytes; no warnings 'redefine'; sub relay_final { my $x = shift; my $self = ref($x) ? $x : $MCE::MCE; _croak('MCE::relay_final: method is not allowed by the worker process') if ($self->{_wid}); my $_caller = caller; if (exists $MCE::RLA->{$_caller}) { if (ref $MCE::RLA->{$_caller} eq '') { return delete $MCE::RLA->{$_caller}; } elsif (ref $MCE::RLA->{$_caller} eq 'HASH') { return %{ delete $MCE::RLA->{$_caller} }; } elsif (ref $MCE::RLA->{$_caller} eq 'ARRAY') { return @{ delete $MCE::RLA->{$_caller} }; } # should not reach the following line delete $MCE::RLA->{$_caller}; } return; } sub relay_recv { my $x = shift; my $self = ref($x) ? $x : $MCE::MCE; _croak('MCE::relay_recv: (init_relay) is not specified') unless (defined $self->{init_relay}); _croak('MCE::relay_recv: method is not allowed by the manager process') unless ($self->{_wid}); _croak('MCE::relay_recv: method is not allowed by task_id > 0') if ($self->{_task_id} > 0); my ($_chn, $_nxt, $_rdr, $_len, $_ref); local $_; $_chn = $self->{_chunk_id} || $self->{_wid}; $_chn = ($_chn - 1) % $self->{max_workers}; $_nxt = $_chn + 1; $_nxt = 0 if ($_nxt == $self->{max_workers}); $_rdr = $self->{_rla_r_sock}->[$_chn]; print {$self->{_dat_w_sock}->[0]} OUTPUT_W_RLA.$LF . '0'.$LF; chomp($_len = <$_rdr>); read $_rdr, $_, $_len; $_ref = chop $_; if ($_ref == 0) { ## scalar value $self->{_rla_data} = $_; return unless defined wantarray; return $self->{_rla_data}; } elsif ($_ref == 1) { ## hash reference $self->{_rla_data} = $self->{thaw}($_); return unless defined wantarray; return %{ $self->{_rla_data} }; } elsif ($_ref == 2) { ## array reference $self->{_rla_data} = $self->{thaw}($_); return unless defined wantarray; return @{ $self->{_rla_data} }; } return; } sub relay (;&) { my ($self, $_code); if (ref $_[0] eq 'CODE') { ($self, $_code) = ($MCE::MCE, shift); } else { my $x = shift; $self = ref($x) ? $x : $MCE::MCE; $_code = shift; } _croak('MCE::relay: (init_relay) is not specified') unless (defined $self->{init_relay}); _croak('MCE::relay: method is not allowed by the manager process') unless ($self->{_wid}); _croak('MCE::relay: method is not allowed by task_id > 0') if ($self->{_task_id} > 0); if (ref $_code ne 'CODE') { _croak('MCE::relay: argument is not a code block') if (defined $_code); } else { weaken $_code; } my ($_chn, $_nxt, $_rdr, $_wtr); $_chn = $self->{_chunk_id} || $self->{_wid}; $_chn = ($_chn - 1) % $self->{max_workers}; $_nxt = $_chn + 1; $_nxt = 0 if ($_nxt == $self->{max_workers}); $_rdr = $self->{_rla_r_sock}->[$_chn]; $_wtr = $self->{_rla_w_sock}->[$_nxt]; if (exists $self->{_rla_data}) { local $_ = delete $self->{_rla_data}; $_code->() if (ref $_code eq 'CODE'); if (ref $_ eq '') { ## scalar value my $_tmp = $_ . '0'; print {$_wtr} length($_tmp) . $LF . $_tmp; } elsif (ref $_ eq 'HASH') { ## hash reference my $_tmp = $self->{freeze}($_) . '1'; print {$_wtr} length($_tmp) . $LF . $_tmp; } elsif (ref $_ eq 'ARRAY') { ## array reference my $_tmp = $self->{freeze}($_) . '2'; print {$_wtr} length($_tmp) . $LF . $_tmp; } } else { my ($_len, $_ref); local $_; print {$self->{_dat_w_sock}->[0]} OUTPUT_W_RLA.$LF . '0'.$LF; chomp($_len = <$_rdr>); read $_rdr, $_, $_len; $_ref = chop $_; if ($_ref == 0) { ## scalar value my $_ret = $_; $_code->() if (ref $_code eq 'CODE'); my $_tmp = $_ . '0'; print {$_wtr} length($_tmp) . $LF . $_tmp; return unless defined wantarray; return $_ret; } elsif ($_ref == 1) { ## hash reference my %_ret = %{ $self->{thaw}($_) }; local $_ = { %_ret }; $_code->() if (ref $_code eq 'CODE'); my $_tmp = $self->{freeze}($_) . '1'; print {$_wtr} length($_tmp) . $LF . $_tmp; return unless defined wantarray; return %_ret; } elsif ($_ref == 2) { ## array reference my @_ret = @{ $self->{thaw}($_) }; local $_ = [ @_ret ]; $_code->() if (ref $_code eq 'CODE'); my $_tmp = $self->{freeze}($_) . '2'; print {$_wtr} length($_tmp) . $LF . $_tmp; return unless defined wantarray; return @_ret; } } return; } ## Aliases. *relay_lock = \&relay_recv; *relay_unlock = \&relay; 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Relay - Extends Many-Core Engine with relay capabilities =head1 VERSION This document describes MCE::Relay version 1.810 =head1 SYNOPSIS use MCE::Flow; my $file = shift || \*STDIN; ## Line Count ####################################### mce_flow_f { max_workers => 4, use_slurpio => 1, init_relay => 0, }, sub { my ($mce, $slurp_ref, $chunk_id) = @_; my $line_count = ($$slurp_ref =~ tr/\n//); ## Receive and pass on updated information. my $lines_read = MCE::relay { $_ += $line_count }; }, $file; my $total_lines = MCE->relay_final; print {*STDERR} "$total_lines\n"; ## Orderly Action ################################### $| = 1; # Important, must flush output immediately. mce_flow_f { max_workers => 2, use_slurpio => 1, init_relay => 0, }, sub { my ($mce, $slurp_ref, $chunk_id) = @_; ## The relay value is relayed and remains 0. ## Writes to STDOUT orderly. MCE->relay_lock; print $$slurp_ref; MCE->relay_unlock; }, $file; =head1 DESCRIPTION This module enables workers to receive and pass on information orderly with zero involvement by the manager process while running. The module is loaded automatically when MCE option C is specified. All workers (belonging to task_id 0) must participate when relaying data. Relaying is not meant for passing big data. The last worker will stall if exceeding the buffer size for the socket. Not exceeding 16 KiB - 7 is safe across all platforms. =head1 API DOCUMENTATION =over 3 =item MCE->relay ( sub { code } ) =item MCE::relay { code } Relay is enabled by specifying the init_relay option which takes a hash or array reference, or a scalar value. Relaying is orderly and driven by chunk_id when processing data, otherwise task_wid. Omitting the code block (e.g. MCE::relay) relays forward. Below, relaying multiple values via a HASH reference. use MCE::Flow max_workers => 4; mce_flow { init_relay => { p => 0, e => 0 }, }, sub { my $wid = MCE->wid; ## do work my $pass = $wid % 3; my $errs = $wid % 2; ## relay my %last_rpt = MCE::relay { $_->{p} += $pass; $_->{e} += $errs }; MCE->print("$wid: passed $pass, errors $errs\n"); return; }; my %results = MCE->relay_final; print " passed $results{p}, errors $results{e} final\n\n"; -- Output 1: passed 1, errors 1 2: passed 2, errors 0 3: passed 0, errors 1 4: passed 1, errors 0 passed 4, errors 2 final Or multiple values via an ARRAY reference. use MCE::Flow max_workers => 4; mce_flow { init_relay => [ 0, 0 ], }, sub { my $wid = MCE->wid; ## do work my $pass = $wid % 3; my $errs = $wid % 2; ## relay my @last_rpt = MCE::relay { $_->[0] += $pass; $_->[1] += $errs }; MCE->print("$wid: passed $pass, errors $errs\n"); return; }; my ($pass, $errs) = MCE->relay_final; print " passed $pass, errors $errs final\n\n"; -- Output 1: passed 1, errors 1 2: passed 2, errors 0 3: passed 0, errors 1 4: passed 1, errors 0 passed 4, errors 2 final Or simply a scalar value. use MCE::Flow max_workers => 4; mce_flow { init_relay => 0, }, sub { my $wid = MCE->wid; ## do work my $bytes_read = 1000 + ((MCE->wid % 3) * 3); ## relay my $last_offset = MCE::relay { $_ += $bytes_read }; ## output MCE->print("$wid: $bytes_read\n"); return; }; my $total = MCE->relay_final; print " $total size\n\n"; -- Output 1: 1003 2: 1006 3: 1000 4: 1003 4012 size =item MCE->relay_final ( void ) Call this method to obtain the final relay value(s) after running. See included example findnull.pl for another use case. use MCE max_workers => 4; my $mce = MCE->new( init_relay => [ 0, 100 ], ## initial values (two counters) user_func => sub { my ($mce) = @_; ## do work my ($acc1, $acc2) = (10, 20); ## relay to next worker MCE::relay { $_->[0] += $acc1; $_->[1] += $acc2 }; return; } )->run; my ($cnt1, $cnt2) = $mce->relay_final; print "$cnt1 : $cnt2\n"; -- Output 40 : 180 =item MCE->relay_recv ( void ) Call this method to obtain the next relay value before relaying. This allows serial-code to be processed orderly between workers. The following is a parallel demonstration for the fasta-benchmark on the web. # perl fasta.pl 25000000 # The Computer Language Benchmarks game # http://benchmarksgame.alioth.debian.org/ # # contributed by Barry Walsh # port of fasta.rb #6 # # MCE::Flow version by Mario Roy # requires MCE 1.807+ # requires MCE::Shared 1.806+ use strict; use warnings; use feature 'say'; use MCE::Flow; use MCE::Shared; use MCE::Candy; use constant IM => 139968; use constant IA => 3877; use constant IC => 29573; my $LAST = MCE::Shared->scalar( 42 ); my $alu = 'GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG' . 'GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA' . 'CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT' . 'ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA' . 'GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG' . 'AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC' . 'AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA'; my $iub = [ [ 'a', 0.27 ], [ 'c', 0.12 ], [ 'g', 0.12 ], [ 't', 0.27 ], [ 'B', 0.02 ], [ 'D', 0.02 ], [ 'H', 0.02 ], [ 'K', 0.02 ], [ 'M', 0.02 ], [ 'N', 0.02 ], [ 'R', 0.02 ], [ 'S', 0.02 ], [ 'V', 0.02 ], [ 'W', 0.02 ], [ 'Y', 0.02 ] ]; my $homosapiens = [ [ 'a', 0.3029549426680 ], [ 'c', 0.1979883004921 ], [ 'g', 0.1975473066391 ], [ 't', 0.3015094502008 ] ]; sub make_repeat_fasta { my ( $src, $n ) = @_; my $width = qr/(.{1,60})/; my $l = length $src; my $s = $src x ( ($n / $l) + 1 ); substr( $s, $n, $l ) = ''; while ( $s =~ m/$width/g ) { say $1 } } sub make_random_fasta { my ( $table, $n ) = @_; my $rand = undef; my $width = 60; my $prob = 0.0; my $output = ''; my ( $c1, $c2, $last ); $_->[1] = ( $prob += $_->[1] ) for @$table; $c1 = '$rand = ( $last = ( $last * IA + IC ) % IM ) / IM;'; $c1 .= "\$output .= '$_->[0]', next if $_->[1] > \$rand;\n" for @$table; my $seq = MCE::Shared->sequence( { chunk_size => 2000, bounds_only => 1 }, 1, $n / $width ); my $code1 = q{ while ( 1 ) { # -------------------------------------------- # Process code orderly between workers. # -------------------------------------------- my $chunk_id = MCE->relay_recv; my ( $begin, $end ) = $seq->next; MCE->relay, last if ( !defined $begin ); my $last = $LAST->get; my $temp = $last; # Pre-compute $LAST value for the next worker for ( 1 .. ( $end - $begin + 1 ) * $width ) { $temp = ( $temp * IA + IC ) % IM; } $LAST->set( $temp ); # Increment chunk_id value MCE->relay( sub { $_ += 1 } ); # -------------------------------------------- # Also run code in parallel between workers. # -------------------------------------------- for ( $begin .. $end ) { for ( 1 .. $width ) { !C! } $output .= "\n"; } # -------------------------------------------- # Display orderly. # -------------------------------------------- MCE->gather( $chunk_id, $output ); $output = ''; } }; $code1 =~ s/!C!/$c1/g; MCE::Flow->init( max_workers => 4, ## MCE::Util->get_ncpu || 4, gather => MCE::Candy::out_iter_fh( \*STDOUT ), init_relay => 1, use_threads => 0, ); MCE::Flow->run( sub { eval $code1 } ); MCE::Flow->finish; $last = $LAST->get; $c2 = '$rand = ( $last = ( $last * IA + IC ) % IM ) / IM;'; $c2 .= "print('$_->[0]'), next if $_->[1] > \$rand;\n" for @$table; my $code2 = q{ if ( $n % $width != 0 ) { for ( 1 .. $n % $width ) { !C! } print "\n"; } }; $code2 =~ s/!C!/$c2/g; eval $code2; $LAST->set( $last ); } my $n = $ARGV[0] || 27; say ">ONE Homo sapiens alu"; make_repeat_fasta( $alu, $n * 2 ); say ">TWO IUB ambiguity codes"; make_random_fasta( $iub, $n * 3 ); say ">THREE Homo sapiens frequency"; make_random_fasta( $homosapiens, $n * 5 ); =item MCE->relay_lock ( void ) =item MCE->relay_unlock ( void ) The C and C methods, added to MCE 1.807, are aliases for C and C respectively. They allow one to perform an exclusive action prior to actual relaying of data. Below, C is taken from the C MCE example. Relaying is driven by C or C when not processing input, thus occurs orderly. user_func => sub { my ($mce, $chunk_ref, $chunk_id) = @_; if ($n_flag) { ## Relays the total lines read. my $output = ''; my $line_count = ($$chunk_ref =~ tr/\n//); my $lines_read = MCE::relay { $_ += $line_count }; open my $fh, '<', $chunk_ref; $output .= sprintf "%6d\t%s", ++$lines_read, $_ while (<$fh>); close $fh; $output .= ":$chunk_id"; MCE->do('display_chunk', $output); } else { ## The following is another way to have ordered output. Workers ## write directly to STDOUT exclusively without any involvement ## from the manager process. The statement(s) between relay_lock ## and relay_unlock run serially and most important orderly. MCE->relay_lock; # alias for MCE->relay_recv print $$chunk_ref; # ensure $| = 1 in script MCE->relay_unlock; # alias for MCE->relay } return; } The following is a variant of the fasta-benchmark demonstration shown above. Here, workers write exclusively and orderly to C. # perl fasta.pl 25000000 # The Computer Language Benchmarks game # http://benchmarksgame.alioth.debian.org/ # # contributed by Barry Walsh # port of fasta.rb #6 # # MCE::Flow version by Mario Roy # requires MCE 1.807+ # requires MCE::Shared 1.806+ use strict; use warnings; use feature 'say'; use MCE::Flow; use MCE::Shared; use constant IM => 139968; use constant IA => 3877; use constant IC => 29573; my $LAST = MCE::Shared->scalar( 42 ); my $alu = 'GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG' . 'GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA' . 'CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT' . 'ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA' . 'GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG' . 'AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC' . 'AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA'; my $iub = [ [ 'a', 0.27 ], [ 'c', 0.12 ], [ 'g', 0.12 ], [ 't', 0.27 ], [ 'B', 0.02 ], [ 'D', 0.02 ], [ 'H', 0.02 ], [ 'K', 0.02 ], [ 'M', 0.02 ], [ 'N', 0.02 ], [ 'R', 0.02 ], [ 'S', 0.02 ], [ 'V', 0.02 ], [ 'W', 0.02 ], [ 'Y', 0.02 ] ]; my $homosapiens = [ [ 'a', 0.3029549426680 ], [ 'c', 0.1979883004921 ], [ 'g', 0.1975473066391 ], [ 't', 0.3015094502008 ] ]; sub make_repeat_fasta { my ( $src, $n ) = @_; my $width = qr/(.{1,60})/; my $l = length $src; my $s = $src x ( ($n / $l) + 1 ); substr( $s, $n, $l ) = ''; while ( $s =~ m/$width/g ) { say $1 } } sub make_random_fasta { my ( $table, $n ) = @_; my $rand = undef; my $width = 60; my $prob = 0.0; my $output = ''; my ( $c1, $c2, $last ); $_->[1] = ( $prob += $_->[1] ) for @$table; $c1 = '$rand = ( $last = ( $last * IA + IC ) % IM ) / IM;'; $c1 .= "\$output .= '$_->[0]', next if $_->[1] > \$rand;\n" for @$table; my $seq = MCE::Shared->sequence( { chunk_size => 2000, bounds_only => 1 }, 1, $n / $width ); my $code1 = q{ $| = 1; # Important, must flush output immediately. while ( 1 ) { # -------------------------------------------- # Process code orderly between workers. # -------------------------------------------- MCE->relay_lock; my ( $begin, $end ) = $seq->next; print( $output ), $output = '' if ( length $output ); MCE->relay_unlock, last if ( !defined $begin ); my $last = $LAST->get; my $temp = $last; # Pre-compute $LAST value for the next worker for ( 1 .. ( $end - $begin + 1 ) * $width ) { $temp = ( $temp * IA + IC ) % IM; } $LAST->set( $temp ); MCE->relay_unlock; # -------------------------------------------- # Also run code in parallel. # -------------------------------------------- for ( $begin .. $end ) { for ( 1 .. $width ) { !C! } $output .= "\n"; } } }; $code1 =~ s/!C!/$c1/g; MCE::Flow->init( max_workers => 4, ## MCE::Util->get_ncpu || 4, init_relay => 0, use_threads => 0, ); MCE::Flow->run( sub { eval $code1 } ); MCE::Flow->finish; $last = $LAST->get; $c2 = '$rand = ( $last = ( $last * IA + IC ) % IM ) / IM;'; $c2 .= "print('$_->[0]'), next if $_->[1] > \$rand;\n" for @$table; my $code2 = q{ if ( $n % $width != 0 ) { for ( 1 .. $n % $width ) { !C! } print "\n"; } }; $code2 =~ s/!C!/$c2/g; eval $code2; $LAST->set( $last ); } my $n = $ARGV[0] || 27; say ">ONE Homo sapiens alu"; make_repeat_fasta( $alu, $n * 2 ); say ">TWO IUB ambiguity codes"; make_random_fasta( $iub, $n * 3 ); say ">THREE Homo sapiens frequency"; make_random_fasta( $homosapiens, $n * 5 ); =back =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.810/lib/MCE/Core.pod0000644000175000017500000017444113022712370013705 0ustar mariomario =head1 NAME MCE::Core - Documentation describing the core MCE API =head1 VERSION This document describes MCE::Core version 1.810 =head1 SYNOPSIS This is a simplistic use case of MCE running with 5 workers. ## Construction using the Core API use MCE; my $mce = MCE->new( max_workers => 5, user_func => sub { my ($mce) = @_; $mce->say("Hello from " . $mce->wid); } ); $mce->run; ## Construction using a MCE model use MCE::Flow max_workers => 5; mce_flow sub { my ($mce) = @_; MCE->say("Hello from " . MCE->wid); }; -- Output Hello from 2 Hello from 4 Hello from 5 Hello from 1 Hello from 3 =head2 MCE->new ( [ options ] ) Below, a new instance is configured with all available options. use MCE; my $mce = MCE->new( max_workers => 8, ## Default 1 # Number of workers to spawn. This can be set automatically # with MCE 1.412 and later releases. # MCE 1.521 sets an upper-limit of 8 for 'auto'. # See MCE::Util::get_ncpu for more info. # max_workers => 'auto', ## # of lcores, 8 maximum # max_workers => 'auto-1', ## 7 on HW with 16-lcores # max_workers => 'auto-1', ## 3 on HW with 4-lcores # max_workers => MCE::Util::get_ncpu, # run on all lcores chunk_size => 2000, ## Default 1 # Can also take a suffix; K (Kilobytes) or M (Megabytes). # The default is 1 when using the Core API and 'auto' for # MCE Models. For arrays or queues, chunk_size means the # number of records per chunk. For iterators, MCE will not # use chunk_size, though the iterator may use it to determine # how much to return per iteration. For files, smaller than or # equal to 8192 is the number of records. Greater than 8192 # is the number of bytes. MCE reads until the end of record # before calling user_func. A value above 64M will change # to 64M quietly (the maximum allowed). # chunk_size => 1, ## Consists of 1 record # chunk_size => 1000, ## Consists of 1000 records # chunk_size => '16K', ## Approximate 16 kilobytes # chunk_size => '20M', ## Approximate 20 megabytes tmp_dir => $tmp_dir, ## Default $MCE::Signal::tmp_dir # Default is $MCE::Signal::tmp_dir which points to # $ENV{TEMP} if defined. Otherwise, tmp_dir points # to a location under /tmp. freeze => \&encode_sereal, ## Default \&Storable::freeze thaw => \&decode_sereal, ## Default \&Storable::thaw # Release 1.412 allows freeze and thaw to be overridden. # Simply include a serialization module prior to loading # MCE. Configure freeze/thaw options. # use Sereal qw( encode_sereal decode_sereal ); # use CBOR::XS qw( encode_cbor decode_cbor ); # use JSON::XS qw( encode_json decode_json ); # # use MCE; gather => \@a, ## Default undef # Release 1.5 allows for gathering of data to an array or # hash reference, a MCE::Queue/Thread::Queue object, or code # reference. One invokes gathering by calling the gather # method as often as needed. # gather => \@array, # gather => \%hash, # gather => $queue, # gather => \&order, init_relay => 0, ## Default undef # For specifying the initial relay value. Allowed values # are array_ref, hash_ref, or scalar. The MCE::Relay module # is loaded automatically when specified. # init_relay => \@array, # init_relay => \%hash, # init_relay => scalar, input_data => $input_file, ## Default undef RS => "\n>", ## Default undef # input_data => '/path/to/file' ## Process file # input_data => \@array ## Process array # input_data => \*FILE_HNDL ## Process file handle # input_data => \$scalar ## Treated like a file # input_data => \&iterator ## User specified iterator # The RS option (for input record separator) applies to files # and file handles. # MCE applies additional logic when RS begins with a newline # character; e.g. RS => "\n>". It trims away characters after # the newline and prepends them to the next record. # # Typically, the left side is what happens for $/ = "\n>". # The right side is what user_func receives. # # All records begin with > and end with \n # Record 1: >seq1 ... \n> (to) >seq1 ... \n # Record 2: seq2 ... \n> >seq2 ... \n # Record 3: seq3 ... \n> >seq3 ... \n # Last Rec: seqN ... \n >seqN ... \n loop_timeout => 5, ## Default 0 # Added in 1.7, enables the manager process to timeout of a read # on channel 0. The manager process decrements the total workers # running for any worker which have died in an uncontrollable # manner. Specify this option if on occassion a worker runs out # of memory or dies due to an error from an XS module. # # A number smaller than 5 is silently increased to 5. max_retries => 2, ## Default 0 # This option, added in 1.7, causes MCE to retry a failed # chunk from a worker dying while processing input data or # sequence of numbers. parallel_io => 1, ## Default 0 posix_exit => 1, ## Default 0 use_slurpio => 1, ## Default 0 # The parallel_io option enables parallel reads during # large slurpio, useful when reading from fast storage. # Do not enable parallel_io when running MCE on many # blades with input coming from shared storage. # Set posix_exit to avoid all END and destructor processing # for non-threads spawned via fork. This is set automatically # to 1 if (F)CGI.pm is present. # Enable slurpio to pass the raw chunk (scalar ref) # to the user function when reading input files. use_threads => 1, ## Auto 0 or 1 # MCE spawns child processes by default, not threads. # # However, MCE supports threads via 2 threading # libraries if threads is desired. # The use of threads in MCE requires that you include # threads support prior to loading MCE. The use_threads # option defaults to 1 when a thread library is loaded. # Threads is loaded automatically for $^O eq 'MSWin32'. # # use threads; use forks; # use threads::shared; (or) use forks::shared; # use MCE use MCE; spawn_delay => 0.035, ## Default undef submit_delay => 0.002, ## Default undef job_delay => 0.150, ## Default undef # Time to wait, in fractional seconds, after spawning # a worker, parameters submission to a worker, and # job commencement (running, staggered delay). # Specify job_delay when wanting to stagger # workers connecting to a database. on_post_exit => \&on_post_exit, ## Default undef on_post_run => \&on_post_run, ## Default undef # Execute code block after a worker exits or dies. # MCE->exit, exit, or die # Execute code block after running. # MCE->process or MCE->run user_args => { env => 'test' }, ## Default undef # MCE release 1.4 added a new parameter to allow one to # specify arbitrary arguments such as a string, an ARRAY # or a HASH reference. Workers can access this directly: # my $args = $mce->{user_args} or MCE->user_args; user_begin => \&user_begin, ## Default undef user_func => \&user_func, ## Default undef user_end => \&user_end, ## Default undef # Think of user_begin, user_func, and user_end as in # the awk scripting language: # awk 'BEGIN { begin } { func } { func } ... END { end }' # MCE workers call user_begin once at the start of a job, # then user_func repeatedly until no chunks remain. # Afterwards, user_end is called. user_error => \&user_error, ## Default undef user_output => \&user_output, ## Default undef # MCE will forward data to user_error/user_output, # when defined, for the following methods. # MCE->sendto(\*STDERR, "sent to user_error\n"); # MCE->printf(\*STDERR, "%s\n", "sent to user_error"); # MCE->print(\*STDERR, "sent to user_error\n"); # MCE->say(\*STDERR, "sent to user_error"); # MCE->sendto(\*STDOUT, "sent to user_output\n"); # MCE->printf("%s\n", "sent to user_output"); # MCE->print("sent to user_output\n"); # MCE->say("sent to user_output"); stderr_file => 'err_file', ## Default STDERR stdout_file => 'out_file', ## Default STDOUT # Or to file; user_error and user_output take precedence. flush_file => 1, ## Default 0 flush_stderr => 1, ## Default 0 flush_stdout => 1, ## Default 0 # Flush sendto file, standard error, or standard output. interval => { delay => 0.007 [, max_nodes => 4, node_id => 1 ] }, # For use with the yield method introduced in MCE 1.5. # Both max_nodes & node_id are optional and default to 1. # Delay is the amount of time between intervals. # interval => 0.007 ## Shorter; MCE 1.506+ sequence => { ## Default undef begin => -1, end => 1 [, step => 0.1 [, format => "%4.1f" ] ] }, bounds_only => 1, ## Default undef # For looping through a sequence of numbers in parallel. # STEP, if omitted, defaults to 1 if BEGIN is smaller than # END or -1 if BEGIN is greater than END. The FORMAT string # is passed to sprintf behind the scene (% may be omitted). # e.g. $seq_n_formatted = sprintf("%4.1f", $seq_n); # Do not specify both options; input_data and sequence. # Release 1.4 allows one to specify an array reference. # e.g. sequence => [ -1, 1, 0.1, "%4.1f" ] # The bounds_only => 1 option will compute the 'begin' and # 'end' items only for the chunk and not the items in between # (hence boundaries only). This option has no effect when # sequence is not specified or chunk_size equals 1. # my $begin = $chunk_ref->[0]; my $end = $chunk_ref->[1]; task_end => \&task_end, ## Default undef # This is called by the manager process after the task # has completed processing. MCE 1.5 allows this option # to be specified at the top level. task_name => 'string', ## Default 'MCE' # Added in MCE 1.5 and mainly beneficial for user_tasks. # One may specify a unique name per each sub-task. # The string is passed as the 3rd arg to task_end. user_tasks => [ ## Default undef { ... }, ## Options for task 0 { ... }, ## Options for task 1 { ... }, ## Options for task 2 ], # Takes a list of hash references, each allowing up to 17 # options. All other MCE options are ignored. The init_relay, # input_data, RS, and use_slurpio options are applicable to # the first task only. # max_workers, chunk_size, input_data, interval, sequence, # bounds_only, user_args, user_begin, user_end, user_func, # gather, task_end, task_name, use_slurpio, use_threads, # init_relay, RS # Options not specified here will default to same option # specified at the top level. ); =head2 EXPORT_CONST, CONST There are 3 constants which are exportable. Using the constants in lieu of 0,1,2 makes it more legible when accessing the user_func arguments directly. =head3 SELF CHUNK CID Exports SELF => 0, CHUNK => 1, and CID => 2. use MCE export_const => 1; use MCE const => 1; ## Shorter; MCE 1.415+ user_func => sub { # my ($mce, $chunk_ref, $chunk_id) = @_; print "Hello from ", $_[SELF]->wid, "\n"; } MCE 1.5 allows all public method to be called directly. use MCE; user_func => sub { # my ($mce, $chunk_ref, $chunk_id) = @_; print "Hello from ", MCE->wid, "\n"; } =head2 OVERRIDING DEFAULTS The following list options which may be overridden when loading the module. use Sereal qw( encode_sereal decode_sereal ); use CBOR::XS qw( encode_cbor decode_cbor ); use JSON::XS qw( encode_json decode_json ); use MCE max_workers => 4, ## Default 1 chunk_size => 100, ## Default 1 tmp_dir => "/path/to/app/tmp", ## $MCE::Signal::tmp_dir freeze => \&encode_sereal, ## \&Storable::freeze thaw => \&decode_sereal ## \&Storable::thaw ; my $mce = MCE->new( ... ); From MCE 1.8 onwards, Sereal 3.008+ is loaded automatically if available. Specify C 0> to use Storable instead. use MCE Sereal => 0; =head2 RUNNING Run calls spawn, submits the job; workers call user_begin, user_func, and user_end. Run shuts down workers afterwards. Call spawn whenever the need arises for large data structures prior to running. $mce->spawn; ## Call early if desired $mce->run; ## Call run or process below ## Acquire data arrays and/or input_files. Workers persist after ## processing. $mce->process(\@input_data_1); ## Process arrays $mce->process(\@input_data_2); $mce->process(\@input_data_n); $mce->process('input_file_1'); ## Process files $mce->process('input_file_2'); $mce->process('input_file_n'); $mce->shutdown; ## Shutdown workers =head2 SYNTAX for ON_POST_EXIT Often times, one may want to capture the exit status. The on_post_exit option, if defined, is executed immediately by the manager process after a worker exits via exit (children only), MCE->exit (children and threads), or die. The format of $e->{pid} is PID_123 for children and THR_123 for threads. my $restart_flag = 1; sub on_post_exit { my ($mce, $e) = @_; ## Display all possible hash elements. print "$e->{wid}: $e->{pid}: $e->{status}: $e->{msg}: $e->{id}\n"; ## Restart this worker if desired. if ($restart_flag && $e->{wid} == 2) { $mce->restart_worker; $restart_flag = 0; } } sub user_func { my ($mce) = @_; MCE->exit(0, 'msg_foo', 1000 + MCE->wid); ## Args, not necessary } my $mce = MCE->new( on_post_exit => \&on_post_exit, user_func => \&user_func, max_workers => 3 ); $mce->run; -- Output (child processes) 2: PID_33223: 0: msg_foo: 1002 1: PID_33222: 0: msg_foo: 1001 3: PID_33224: 0: msg_foo: 1003 2: PID_33225: 0: msg_foo: 1002 -- Output (running with threads) 3: TID_3: 0: msg_foo: 1003 2: TID_2: 0: msg_foo: 1002 1: TID_1: 0: msg_foo: 1001 2: TID_4: 0: msg_foo: 1002 =head2 SYNTAX for ON_POST_RUN The on_post_run option, if defined, is executed immediately by the manager process after running MCE->process or MCE->run. This option receives an array reference of hashes. The difference between on_post_exit and on_post_run is that the former is called immediately whereas the latter is called after all workers have completed running. sub on_post_run { my ($mce, $status_ref) = @_; foreach my $e ( @{ $status_ref } ) { ## Display all possible hash elements. print "$e->{wid}: $e->{pid}: $e->{status}: $e->{msg}: $e->{id}\n"; } } sub user_func { my ($mce) = @_; MCE->exit(0, 'msg_foo', 1000 + MCE->wid); ## Args, not necessary } my $mce = MCE->new( on_post_run => \&on_post_run, user_func => \&user_func, max_workers => 3 ); $mce->run; -- Output (child processes) 3: PID_33174: 0: msg_foo: 1003 1: PID_33172: 0: msg_foo: 1001 2: PID_33173: 0: msg_foo: 1002 -- Output (running with threads) 2: TID_2: 0: msg_foo: 1002 3: TID_3: 0: msg_foo: 1003 1: TID_1: 0: msg_foo: 1001 =head2 SYNTAX for INPUT_DATA MCE supports many ways to specify input_data. Support for iterators was added in MCE 1.505. The RS option allows one to specify the record separator when processing files. MCE is a chunking engine. Therefore, chunk_size is applicable to input_data. Specifying 1 for use_slurpio causes user_func to receive a scalar reference containing the raw data (applicable to files only) instead of an array reference. input_data => '/path/to/file', ## process file input_data => \@array, ## process array input_data => \*FILE_HNDL, ## process file handle input_data => $fh, ## open $fh, "<", "file" input_data => $fh, ## IO::File "file", "r" input_data => $fh, ## IO::Uncompress::Gunzip "file.gz" input_data => \$scalar, ## treated like a file input_data => \&iterator, ## user specified iterator chunk_size => 1, ## >1 means looping inside user_func use_slurpio => 1, ## $chunk_ref is a scalar ref RS => "\n>", ## input record separator The chunk_size value determines the chunking mode to use when processing files. Otherwise, chunk_size is the number of elements for arrays. For files, a chunk size value of <= 8192 is how many records to read. Greater than 8192 is how many bytes to read. MCE appends (the rest) up to the next record separator. chunk_size => 8192, ## Consists of 8192 records chunk_size => 8193, ## Approximate 8193 bytes for files chunk_size => 1, ## Consists of 1 record or element chunk_size => 1000, ## Consists of 1000 records chunk_size => '16K', ## Approximate 16 kilobytes chunk_size => '20M', ## Approximate 20 megabytes The construction for user_func when chunk_size > 1 and assuming use_slurpio equals 0. user_func => sub { my ($mce, $chunk_ref, $chunk_id) = @_; ## $_ is $chunk_ref->[0] when chunk_size equals 1 ## $_ is $chunk_ref otherwise; $_ can be used below for my $record ( @{ $chunk_ref } ) { print "$chunk_id: $record\n"; } } Specifying a value for input_data is straight forward for arrays and files. The next several examples specify an iterator reference for input_data. use MCE; ## A factory function which creates a closure (the iterator itself) ## for generating a sequence of numbers. The external variables ## ($n, $max, $step) are used for keeping state across successive ## calls to the closure. The iterator simply returns when $n > max. sub input_iterator { my ($n, $max, $step) = @_; return sub { return if $n > $max; my $current = $n; $n += $step; return $current; }; } ## Run user_func in parallel. Input data can be specified during ## the construction or as an argument to the process method. my $mce = MCE->new( # input_data => input_iterator(10, 30, 2), chunk_size => 1, max_workers => 4, user_func => sub { my ($mce, $chunk_ref, $chunk_id) = @_; MCE->print("$_: ", $_ * 2, "\n"); } )->spawn; $mce->process( input_iterator(10, 30, 2) ); -- Output Note that output order is not guaranteed Take a look at iterator.pl for ordered output 10: 20 12: 24 16: 32 20: 40 14: 28 22: 44 18: 36 24: 48 26: 52 28: 56 30: 60 The following example queries the DB for the next 1000 rows. Notice the use of fetchall_arrayref. The iterator function itself receives one argument which is chunk_size (added in MCE 1.510) to determine how much to return per iteration. The default is 1 for the Core API and MCE Models. use DBI; use MCE; sub db_iter { my $dsn = "DBI:Oracle:host=db_server;port=db_port;sid=db_name"; my $dbh = DBI->connect($dsn, 'db_user', 'db_passwd') || die "Could not connect to database: $DBI::errstr"; my $sth = $dbh->prepare('select color, desc from table'); $sth->execute; return sub { my ($chunk_size) = @_; if (my $aref = $sth->fetchall_arrayref(undef, $chunk_size)) { return @{ $aref }; } return; }; } ## Let's enumerate column indexes for easy column retrieval. my ($i_color, $i_desc) = (0 .. 1); my $mce = MCE->new( max_workers => 3, chunk_size => 1000, input_data => db_iter(), user_func => sub { my ($mce, $chunk_ref, $chunk_id) = @_; my $ret = ''; foreach my $row (@{ $chunk_ref }) { $ret .= $row->[$i_color] .": ". $row->[$i_desc] ."\n"; } MCE->print($ret); } ); $mce->run; There are many modules on CPAN which return an iterator reference. Showing one such example below. The demonstration ensures MCE workers are spawned before obtaining the iterator. Note the worker_id value (left column) in the output. use Path::Iterator::Rule; use MCE; my $start_dir = shift or die "Please specify a starting directory"; -d $start_dir or die "Cannot open ($start_dir): No such file or directory"; my $mce = MCE->new( max_workers => 'auto', user_func => sub { MCE->say( MCE->wid . ": $_" ) } )->spawn; my $rule = Path::Iterator::Rule->new->file->name( qr/[.](pm)$/ ); my $iterator = $rule->iter( $start_dir, { follow_symlinks => 0, depthfirst => 1 } ); $mce->process( $iterator ); -- Output 8: lib/MCE/Core/Input/Generator.pm 5: lib/MCE/Core/Input/Handle.pm 6: lib/MCE/Core/Input/Iterator.pm 2: lib/MCE/Core/Input/Request.pm 3: lib/MCE/Core/Manager.pm 4: lib/MCE/Core/Input/Sequence.pm 7: lib/MCE/Core/Validation.pm 1: lib/MCE/Core/Worker.pm 8: lib/MCE/Flow.pm 5: lib/MCE/Grep.pm 6: lib/MCE/Loop.pm 2: lib/MCE/Map.pm 3: lib/MCE/Queue.pm 4: lib/MCE/Signal.pm 7: lib/MCE/Stream.pm 1: lib/MCE/Subs.pm 8: lib/MCE/Util.pm 5: lib/MCE.pm Although MCE supports arrays, extra measures are needed to use a "lazy" array as input data. The reason for this is that MCE needs the size of the array before processing which may be unknown for lazy arrays. Therefore, closures provides an excellent mechanism for this. The code block belonging to the lazy array must return undef after exhausting its input data. Otherwise, the process will never end. use Tie::Array::Lazy; use MCE; tie my @a, 'Tie::Array::Lazy', [], sub { my $i = $_[0]->index; return ($i < 10) ? $i : undef; }; sub make_iterator { my $i = 0; my $a_ref = shift; return sub { return $a_ref->[$i++]; }; } my $mce = MCE->new( max_workers => 4, input_data => make_iterator(\@a), user_func => sub { my ($mce, $chunk_ref, $chunk_id) = @_; MCE->say($_); } )->run; -- Output 0 1 2 3 4 6 7 8 5 9 The following demonstrates how to retrieve a chunk from the lazy array per each successive call. Here, undef is sent by the iterator block when $i is greater than $max. Iterators may optionally use chunk_size to determine how much to return per iteration. use Tie::Array::Lazy; use MCE; tie my @a, 'Tie::Array::Lazy', [], sub { $_[0]->index; }; sub make_iterator { my $j = 0; my ($a_ref, $max) = @_; return sub { my ($chunk_size) = @_; my $i = $j; $j += $chunk_size; return if $i > $max; return $j <= $max ? @$a_ref[$i .. $j - 1] : @$a_ref[$i .. $max]; }; } my $mce = MCE->new( chunk_size => 15, max_workers => 4, input_data => make_iterator(\@a, 100), user_func => sub { my ($mce, $chunk_ref, $chunk_id) = @_; MCE->say("$chunk_id: " . join(' ', @{ $chunk_ref })); } )->run; -- Output 1: 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 2: 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 3: 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 4: 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 5: 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 6: 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 7: 90 91 92 93 94 95 96 97 98 99 100 =head2 SYNTAX for SEQUENCE The 1.3 release and above allows workers to loop through a sequence of numbers computed mathematically without the overhead of an array. The sequence can be specified separately per each user_task entry unlike input_data which is applicable to the first task only. See the seq_demo.pl example, included with this distribution, on applying sequences with the user_tasks option. Sequence can be defined using an array or a hash reference. use MCE; my $mce = MCE->new( max_workers => 3, # sequence => [ 10, 19, 0.7, "%4.1f" ], ## up to 4 options sequence => { begin => 10, end => 19, step => 0.7, format => "%4.1f" }, user_func => sub { my ($mce, $n, $chunk_id) = @_; print $n, " from ", MCE->wid, " id ", $chunk_id, "\n"; } ); $mce->run; -- Output (sorted afterwards, notice wid and chunk_id in output) 10.0 from 1 id 1 10.7 from 2 id 2 11.4 from 3 id 3 12.1 from 1 id 4 12.8 from 2 id 5 13.5 from 3 id 6 14.2 from 1 id 7 14.9 from 2 id 8 15.6 from 3 id 9 16.3 from 1 id 10 17.0 from 2 id 11 17.7 from 3 id 12 18.4 from 1 id 13 The 1.5 release includes a new option (bounds_only). This option tells the sequence engine to compute 'begin' and 'end' items only, for the chunk, and not the items in between (hence boundaries only). This option applies to sequence only and has no effect when chunk_size equals 1. The time to run is 0.006s below. This becomes 0.827s without the bounds_only option due to computing all items in between, thus creating a very large array. Basically, specify bounds_only => 1 when boundaries is all you need for looping inside the block; e.g. Monte Carlo simulations. Time was measured using 1 worker to emphasize the difference. use MCE; my $mce = MCE->new( max_workers => 1, chunk_size => 1_250_000, sequence => { begin => 1, end => 10_000_000 }, bounds_only => 1, ## For sequence, the input scalar $_ points to $chunk_ref ## when chunk_size > 1, otherwise $chunk_ref->[0]. ## ## user_func => sub { ## my $begin = $_->[0]; my $end = $_->[-1]; ## ## for ($begin .. $end) { ## ... ## } ## }, user_func => sub { my ($mce, $chunk_ref, $chunk_id) = @_; ## $chunk_ref contains 2 items, not 1_250_000 my $begin = $chunk_ref->[ 0]; my $end = $chunk_ref->[-1]; ## or $chunk_ref->[1] MCE->printf("%7d .. %8d\n", $begin, $end); } ); $mce->run; -- Output 1 .. 1250000 1250001 .. 2500000 2500001 .. 3750000 3750001 .. 5000000 5000001 .. 6250000 6250001 .. 7500000 7500001 .. 8750000 8750001 .. 10000000 =head2 SYNTAX for MAX_RETRIES The max_retries option, added in 1.7, causes MCE to retry a failed chunk from a worker dying while processing input data or sequence of numbers. MCE configures the on_post_exit option with the following code in the absence of on_post_exit. Otherwise, simply tailor this into your on_post_exit code. ## What is done behind the scene when max_retries is specified and ## omitting the on_post_exit option in MCE. sub on_post_exit { my ($mce, $e, $retry_cnt) = @_; my ($cnt, $msg) = ($retry_cnt + 1, "Error: Chunk $e->{id} failed"); ($retry_cnt < $mce->max_retries) ? print {*STDERR} "$msg, retrying chunk attempt #${cnt}\n" : print {*STDERR} "$msg\n"; $mce->restart_worker; } ## Running MCE with max_retries. use strict; use warnings; use MCE; sub user_func { my ($mce, $chunk_ref, $chunk_id) = @_; die "Died : chunk_id == 3" if $chunk_id == 3; print "$mce->{_wid}: $chunk_id\n"; } my $mce = MCE->new( max_workers => 1, user_func => \&user_func, max_retries => 2, )->spawn; my @input_data; push @input_data, qw( 0 1 2 3 4 5 6 7 ); $mce->process( { chunk_size => 1 }, \@input_data ); $mce->shutdown; -- Output 1: 1 1: 2 Died : chunk_id == 3 at script.pl line 8, <__ANONIO__> line 6. Error: Chunk 3 failed, retrying chunk attempt #1 Died : chunk_id == 3 at script.pl line 8, <__ANONIO__> line 7. Error: Chunk 3 failed, retrying chunk attempt #2 Died : chunk_id == 3 at script.pl line 8, <__ANONIO__> line 14. Error: Chunk 3 failed 1: 4 1: 5 1: 6 1: 7 1: 8 =head2 SYNTAX for USER_BEGIN and USER_END The user_begin and user_end options, if specified, behave similarly to awk 'BEGIN { begin } { func } { func } ... END { end }'. These are called once per worker during each run. MCE 1.510 passes 2 additional parameters ($task_id and $task_name). sub user_begin { ## Called once at the beginning my ($mce, $task_id, $task_name) = @_; $mce->{wk_total_rows} = 0; } sub user_func { ## Called while processing my $mce = shift; $mce->{wk_total_rows} += 1; } sub user_end { ## Called once at the end my ($mce, $task_id, $task_name) = @_; printf "## %d: Processed %d rows\n", MCE->wid, $mce->{wk_total_rows}; } my $mce = MCE->new( user_begin => \&user_begin, user_func => \&user_func, user_end => \&user_end ); $mce->run; =head2 SYNTAX for USER_FUNC with USE_SLURPIO => 0 When processing input data, MCE can pass an array of rows or a slurped chunk. Below, a reference to an array containing the chunk data is processed. e.g. $chunk_ref = [ record1, record2, record3, ... ] sub user_func { my ($mce, $chunk_ref, $chunk_id) = @_; foreach my $row ( @{ $chunk_ref } ) { $mce->{wk_total_rows} += 1; print $row; } } my $mce = MCE->new( chunk_size => 100, input_data => "/path/to/file", user_func => \&user_func, use_slurpio => 0 ); $mce->run; =head2 SYNTAX for USER_FUNC with USE_SLURPIO => 1 Here, a reference to a scalar containing the raw chunk data is processed. sub user_func { my ($mce, $chunk_ref, $chunk_id) = @_; my $count = () = $$chunk_ref =~ /abc/; } my $mce = MCE->new( chunk_size => 16000, input_data => "/path/to/file", user_func => \&user_func, use_slurpio => 1 ); $mce->run; =head2 SYNTAX for USER_ERROR and USER_OUTPUT Output from MCE->sendto('STDERR/STDOUT', ...), MCE->printf, MCE->print, and MCE->say can be intercepted by specifying the user_error and user_output options. MCE on receiving output will forward to user_error or user_output in a serialized fashion. Handy when wanting to filter, modify, and/or direct the output elsewhere. sub user_error { ## Redirect STDERR to STDOUT my $error = shift; print {*STDOUT} $error; } sub user_output { ## Redirect STDOUT to STDERR my $output = shift; print {*STDERR} $output; } sub user_func { my ($mce, $chunk_ref, $chunk_id) = @_; my $count = 0; foreach my $row ( @{ $chunk_ref } ) { MCE->print($row); $count += 1; } MCE->print(\*STDERR, "$chunk_id: processed $count rows\n"); } my $mce = MCE->new( chunk_size => 1000, input_data => "/path/to/file", user_error => \&user_error, user_output => \&user_output, user_func => \&user_func ); $mce->run; =head2 SYNTAX for USER_TASKS and TASK_END This option takes an array of tasks. Each task allows up to 17 options. The init_relay, input_data, RS, and use_slurpio options may be defined inside the first task or at the top level, otherwise ignored under other sub-tasks. max_workers, chunk_size, input_data, interval, sequence, bounds_only, user_args, user_begin, user_end, user_func, gather, task_end, task_name, use_slurpio, use_threads, init_relay, RS Sequence and chunk_size were added in 1.3. User_args was introduced in 1.4. Name and input_data are new options allowed in 1.5. In addition, one can specify task_end at the top level. Task_end also receives 2 additional arguments $task_id and $task_name (shown below). Options not specified here will default to the same option specified at the top level. The task_end option is called by the manager process when all workers for that sub-task have completed processing. Forking and threading can be intermixed among tasks unless running Cygwin. The run method will continue running until all workers have completed processing. use threads; use threads::shared; use MCE; sub parallel_task1 { sleep 2; } sub parallel_task2 { sleep 1; } my $mce = MCE->new( task_end => sub { my ($mce, $task_id, $task_name) = @_; print "Task [$task_id -- $task_name] completed processing\n"; }, user_tasks => [{ task_name => 'foo', max_workers => 2, user_func => \¶llel_task1, use_threads => 0 ## Not using threads },{ task_name => 'bar', max_workers => 4, user_func => \¶llel_task2, use_threads => 1 ## Yes, threads }] ); $mce->run; -- Output Task [1 -- bar] completed processing Task [0 -- foo] completed processing =head1 DEFAULT INPUT SCALAR Beginning with MCE 1.5, the input scalar $_ is localized prior to calling user_func for input_data and sequence of numbers. The following applies. =over 3 =item use_slurpio => 1 $_ is a reference to the buffer e.g. $_ = \$_buffer; $_ is a reference regardless of whether chunk_size is 1 or greater user_func => sub { # my ($mce, $chunk_ref, $chunk_id) = @_; print ${ $_ }; ## $_ is same as $chunk_ref } =item chunk_size is greater than 1, use_slurpio => 0 $_ is a reference to an array. $_ = \@_records; $_ = \@_seq_n; $_ is same as $chunk_ref or $_[CHUNK] user_func => sub { # my ($mce, $chunk_ref, $chunk_id) = @_; for my $row ( @{ $_ } ) { print $row, "\n"; } } use MCE const => 1; user_func => sub { # my ($mce, $chunk_ref, $chunk_id) = @_; for my $row ( @{ $_[CHUNK] } ) { print $row, "\n"; } } =item chunk_size equals 1, use_slurpio => 0 $_ contains the actual value. $_ = $_buffer; $_ = $seq_n; ## Note that $_ and $chunk_ref are not the same below. ## $chunk_ref is a reference to an array. user_func => sub { # my ($mce, $chunk_ref, $chunk_id) = @_; print $_, "\n; ## Same as $chunk_ref->[0]; } $mce->foreach("/path/to/file", sub { # my ($mce, $chunk_ref, $chunk_id) = @_; print $_; ## Same as $chunk_ref->[0]; }); ## However, that is not the case for the forseq method. ## Both $_ and $n_seq are the same when chunk_size => 1. $mce->forseq([ 1, 9 ], sub { # my ($mce, $n_seq, $chunk_id) = @_; print $_, "\n"; ## Same as $n_seq }); Sequence can also be specified using an array reference. The below is the same as the example afterwards. $mce->forseq( { begin => 10, end => 40, step => 2 }, ... ); The code block receives an array containing the next 5 sequences. Chunk 1 (chunk_id 1) contains 10,12,14,16,18. $n_seq is a reference to an array, same as $_, due to chunk_size being greater than 1. $mce->forseq( [ 10, 40000, 2 ], { chunk_size => 5 }, sub { # my ($mce, $n_seq, $chunk_id) = @_; my @result; for my $n ( @{ $_ } ) { ... do work, append to result for 5 } ... do something with result afterwards }); =back =head1 METHODS for the MANAGER PROCESS and WORKERS The methods listed below are callable by the main process and workers. =head2 $mce->abort ( void ) The 'abort' method is applicable when processing input_data only. This causes all workers to abort after processing the current chunk. Workers write the next offset position to the queue socket for the next available worker. In essence, the 'abort' method writes the last offset position. Workers, on requesting the next offset position, will think the end of input_data has been reached and leave the chunking loop. $mce->abort; MCE->abort; =head2 $mce->chunk_id ( void ) Returns the chunk_id for the current chunk. The value starts at 1. Chunking applies to input_data or sequence. The value is 0 for the manager process. my $chunk_id = $mce->chunk_id; my $chunk_id = MCE->chunk_id; =head2 $mce->chunk_size ( void ) Getter method for chunk_size used by MCE. my $chunk_size = $mce->chunk_size; my $chunk_size = MCE->chunk_size; =head2 $mce->freeze ( $object_ref ) Calls the internal freeze method to serialize an object. The default serialization routines are handled by Sereal if available or Storable. my $frozen = $mce->freeze([ 0, 2, 4 ]); my $frozen = MCE->freeze([ 0, 2, 4 ]); =head2 $mce->max_retries ( void ) Getter method for max_retries used by MCE. my $max_retries = $mce->max_retries; my $max_retries = MCE->max_retries; =head2 $mce->max_workers ( void ) Getter method for max_workers used by MCE. my $max_workers = $mce->max_workers; my $max_workers = MCE->max_workers; =head2 $mce->pid ( void ) Returns the Process ID. Threads have thread ID attached to the value. my $pid = $mce->pid; ## 16180 (pid) ; 16180.2 (pid.tid) my $pid = MCE->pid; =head2 $mce->sess_dir ( void ) Returns the session directory used by the MCE instance. This is defined during spawning and removed during shutdown. my $sess_dir = $mce->sess_dir; my $sess_dir = MCE->sess_dir; =head2 $mce->task_id ( void ) Returns the task ID. This applies to the user_tasks option (starts at 0). my $task_id = $mce->task_id; my $task_id = MCE->task_id; =head2 $mce->task_name ( void ) Returns the task_name value specified via the task_name option when configuring MCE. my $task_name = $mce->task_name; my $task_name = MCE->task_name; =head2 $mce->task_wid ( void ) Returns the task worker ID (applies to user_tasks). The value starts at 1 per each task configured within user_tasks. The value is 0 for the manager process. my $task_wid = $mce->task_wid; my $task_wid = MCE->task_wid; =head2 $mce->thaw ( $frozen ) Calls the internal thaw method to un-serialize the frozen object. my $object_ref = $mce->thaw($frozen); my $object_ref = MCE->thaw($frozen); =head2 $mce->tmp_dir ( void ) Returns the temporary directory used by MCE. my $tmp_dir = $mce->tmp_dir; my $tmp_dir = MCE->tmp_dir; =head2 $mce->user_args ( void ) Returns the arguments specified via the user_args option. my ($arg1, $arg2, $arg3) = $mce->user_args; my ($arg1, $arg2, $arg3) = MCE->user_args; =head2 $mce->wid ( void ) Returns the MCE worker ID. Starts at 1 per each MCE instance. The value is 0 for the manager process. my $wid = $mce->wid; my $wid = MCE->wid; =head1 METHODS for the MANAGER PROCESS only Methods listed below are callable by the main process only. =head2 $mce->forchunk ( $input_data [, { options } ], sub { ... } ) =head2 $mce->foreach ( $input_data [, { options } ], sub { ... } ) =head2 $mce->forseq ( $sequence_spec [, { options } ], sub { ... } ) Forchunk, foreach, and forseq are sugar methods and described in L. Stubs exist in MCE which load MCE::Candy automatically. =head2 $mce->process ( $input_data [, { options } ] ) The process method will spawn workers automatically if not already spawned. It will set input_data => $input_data. It calls run(0) to not auto-shutdown workers. Specifying options is optional. Allowable options { key => value, ... } are: chunk_size input_data job_delay spawn_delay submit_delay flush_file flush_stderr flush_stdout stderr_file stdout_file on_post_exit on_post_run sequence user_args user_begin user_end user_func user_error user_output use_slurpio RS Options remain persistent going forward unless changed. Setting user_begin, user_end, or user_func will cause already spawned workers to shut down and re-spawn automatically. Therefore, define these during instantiation. The below will cause workers to re-spawn after running. my $mce = MCE->new( max_workers => 'auto' ); $mce->process( { user_begin => sub { ## connect to DB }, user_func => sub { ## process each row }, user_end => sub { ## close handle to DB }, }, \@input_data ); $mce->process( { user_begin => sub { ## connect to DB }, user_func => sub { ## process each file }, user_end => sub { ## close handle to DB }, }, "/list/of/files" ); Do the following if wanting workers to persist between jobs. use MCE max_workers => 'auto'; my $mce = MCE->new( user_begin => sub { ## connect to DB }, user_func => sub { ## process each chunk or row or host }, user_end => sub { ## close handle to DB }, ); $mce->spawn; ## Spawn early if desired $mce->process("/one/very_big_file/_mce_/will_chunk_in_parallel"); $mce->process(\@array_of_files_to_grep); $mce->process("/path/to/host/list"); $mce->process($array_ref); $mce->process($array_ref, { stdout_file => $output_file }); ## This was not allowed before. Fixed in 1.415. $mce->process({ sequence => { begin => 10, end => 90, step 2 } }); $mce->process({ sequence => [ 10, 90, 2 ] }); $mce->shutdown; =head2 $mce->relay_final ( void ) Described in L. =head2 $mce->restart_worker ( void ) One can restart a worker who has died or exited. The job never ends below due to restarting each time. Recommended is to call MCE->exit or $mce->exit instead of the native exit function for better handling, especially under the Windows environment. The $e->{wid} argument is no longer necessary starting with the 1.5 release. Press [ctrl-c] to terminate the script. my $mce = MCE->new( on_post_exit => sub { my ($mce, $e) = @_; print "$e->{wid}: $e->{pid}: status $e->{status}: $e->{msg}"; # $mce->restart_worker($e->{wid}); ## MCE-1.415 and below $mce->restart_worker; ## MCE-1.500 and above }, user_begin => sub { my ($mce, $task_id, $task_name) = @_; ## Not interested in die messages going to STDERR, ## because the die handler calls MCE->exit(255, $_[0]). close STDERR; }, user_tasks => [{ max_workers => 5, user_func => sub { my ($mce) = @_; sleep MCE->wid; MCE->exit(3, "exited from " . MCE->wid . "\n"); } },{ max_workers => 4, user_func => sub { my ($mce) = @_; sleep MCE->wid; die("died from " . MCE->wid . "\n"); } }] ); $mce->run; -- Output 1: PID_85388: status 3: exited from 1 2: PID_85389: status 3: exited from 2 1: PID_85397: status 3: exited from 1 3: PID_85390: status 3: exited from 3 1: PID_85399: status 3: exited from 1 4: PID_85391: status 3: exited from 4 2: PID_85398: status 3: exited from 2 1: PID_85401: status 3: exited from 1 5: PID_85392: status 3: exited from 5 1: PID_85404: status 3: exited from 1 6: PID_85393: status 255: died from 6 3: PID_85400: status 3: exited from 3 2: PID_85403: status 3: exited from 2 1: PID_85406: status 3: exited from 1 7: PID_85394: status 255: died from 7 1: PID_85410: status 3: exited from 1 8: PID_85395: status 255: died from 8 4: PID_85402: status 3: exited from 4 2: PID_85409: status 3: exited from 2 1: PID_85412: status 3: exited from 1 9: PID_85396: status 255: died from 9 3: PID_85408: status 3: exited from 3 1: PID_85416: status 3: exited from 1 ... =head2 $mce->run ( [ $auto_shutdown [, { options } ] ] ) The run method, by default, spawns workers, processes once, and shuts down afterwards. Specify 0 for $auto_shutdown when wanting workers to persist after running (default 1). Specifying options is optional. Valid options are the same as for the process method. my $mce = MCE->new( ... ); ## Disables auto-shutdown $mce->run(0); =head2 $mce->send ( $data_ref ) The 'send' method is useful when wanting to spawn workers early to minimize memory consumption and afterwards send data individually to each worker. One cannot send more than the total workers spawned. Workers store the received data as $mce->{user_data}. The data which can be sent is restricted to an ARRAY, HASH, or PDL reference. Workers begin processing immediately after receiving data. Workers set $mce->{user_data} to undef after processing. One cannot specify input_data, sequence, or user_tasks when using the "send" method. Passing any options e.g. run(0, { options }) is ignored due to workers running immediately after receiving user data. There is no guarantee to which worker will receive data first. It depends on which worker is available awaiting data. use MCE; my $mce = MCE->new( max_workers => 5, user_func => sub { my ($mce) = @_; my $data = $mce->{user_data}; my $first_name = $data->{first_name}; print MCE->wid, ": Hello from $first_name\n"; } ); $mce->spawn; ## Optional, send will spawn if necessary. $mce->send( { first_name => "Theresa" } ); $mce->send( { first_name => "Francis" } ); $mce->send( { first_name => "Padre" } ); $mce->send( { first_name => "Anthony" } ); $mce->run; ## Wait for workers to complete processing. -- Output 2: Hello from Theresa 5: Hello from Anthony 3: Hello from Francis 4: Hello from Padre =head2 $mce->shutdown ( void ) The run method will automatically spawn workers, run once, and shutdown workers automatically. Workers persist after running below. Shutdown may be called as needed or prior to exiting. my $mce = MCE->new( ... ); $mce->spawn; $mce->process(\@input_data_1); ## Processing multiple arrays $mce->process(\@input_data_2); $mce->process(\@input_data_n); $mce->shutdown; $mce->process('input_file_1'); ## Processing multiple files $mce->process('input_file_2'); $mce->process('input_file_n'); $mce->shutdown; =head2 $mce->spawn ( void ) Workers are normally spawned automatically. The spawn method allows one to spawn workers early if so desired. my $mce = MCE->new( ... ); $mce->spawn; =head2 $mce->status ( void ) The greatest exit status is saved among workers while running. Look at the on_post_exit or on_post_run options for callback support. my $mce = MCE->new( ... ); $mce->run; my $exit_status = $mce->status; =head1 METHODS for WORKERS only Methods listed below are callable by workers only. =head2 $mce->do ( 'callback_func' [, $arg1, ... ] ) MCE serializes data transfers from a worker process via helper functions do & sendto to the manager process. The callback function can optionally return a reply. [ $reply = ] MCE->do('callback' [, $arg1, ... ]); Passing args to a callback function using references & scalar. sub callback { my ($array_ref, $hash_ref, $scalar_ref, $scalar) = @_; ... } MCE->do('main::callback', \@a, \%h, \$s, 'foo'); MCE->do('callback', \@a, \%h, \$s, 'foo'); MCE knows if wanting a void, list, hash, or a scalar return value. MCE->do('callback' [, $arg1, ... ]); my @array = MCE->do('callback' [, $arg1, ... ]); my %hash = MCE->do('callback' [, $arg1, ... ]); my $scalar = MCE->do('callback' [, $arg1, ... ]); =head2 $mce->exit ( [ $status [, $message [, $id ] ] ] ) A worker exits from MCE entirely. $id (optional) can be used for passing the primary key or a string along with the message. Look at the on_post_exit or on_post_run options for callback support. MCE->exit; ## default 0 MCE->exit(1); MCE->exit(2, 'chunk failed', $chunk_id); MCE->exit(0, 'msg_foo', 'id_1000'); =head2 $mce->gather ( $arg1, [, $arg2, ... ] ) A worker can submit data to the location specified via the gather option by calling this method. See L and L for additional use-case. use MCE; my @hosts = qw( hosta hostb hostc hostd hoste ); my $mce = MCE->new( chunk_size => 1, max_workers => 3, user_func => sub { # my ($mce, $chunk_ref, $chunk_id) = @_; my ($output, $error, $status); my $host = $_; ## Do something with $host; $output = "Worker ". MCE->wid .": Hello from $host"; if (MCE->chunk_id % 3 == 0) { ## Simulating an error condition local $? = 1; $status = $?; $error = "Error from $host" } else { $status = 0; } ## Ensure unique keys (key, value) when gathering to a ## hash. MCE->gather("$host.out", $output, "$host.sta", $status); MCE->gather("$host.err", $error) if (defined $error); } ); my %h; $mce->process(\@hosts, { gather => \%h }); foreach my $host (@hosts) { print $h{"$host.out"}, "\n"; print $h{"$host.err"}, "\n" if (exists $h{"$host.err"}); print "Exit status: ", $h{"$host.sta"}, "\n\n"; } -- Output Worker 2: Hello from hosta Exit status: 0 Worker 1: Hello from hostb Exit status: 0 Worker 3: Hello from hostc Error from hostc Exit status: 1 Worker 2: Hello from hostd Exit status: 0 Worker 1: Hello from hoste Exit status: 0 =head2 $mce->last ( void ) Worker leaves the chunking loop or user_func block immediately. Callable from inside foreach, forchunk, forseq, and user_func. use MCE; my $mce = MCE->new( max_workers => 5 ); my @list = (1 .. 80); $mce->forchunk(\@list, { chunk_size => 2 }, sub { my ($mce, $chunk_ref, $chunk_id) = @_; MCE->last if ($chunk_id > 4); my @output = (); foreach my $rec ( @{ $chunk_ref } ) { push @output, $rec, "\n"; } MCE->print(@output); }); -- Output (each chunk above consists of 2 elements) 3 4 1 2 7 8 5 6 =head2 $mce->next ( void ) Worker starts the next iteration of the chunking loop. Callable from inside foreach, forchunk, forseq, and user_func. use MCE; my $mce = MCE->new( max_workers => 5 ); my @list = (1 .. 80); $mce->forchunk(\@list, { chunk_size => 4 }, sub { my ($mce, $chunk_ref, $chunk_id) = @_; MCE->next if ($chunk_id < 20); my @output = (); foreach my $rec ( @{ $chunk_ref } ) { push @output, $rec, "\n"; } MCE->print(@output); }); -- Output (each chunk above consists of 4 elements) 77 78 79 80 =head2 $mce->printf ( $format, $list [, ... ] ) =head2 $mce->print ( $list [, ... ] ) =head2 $mce->say ( $list [, ... ] ) Use the printf, print, and say methods when wanting to serialize output among workers. These are sugar syntax for the sendto method. These behave similar to the native subroutines in Perl with the exception that barewords must be passed as a reference and require the comma after it including file handles. Say is like print, but implicitly appends a newline. MCE->printf(\*STDOUT, "%s: %d\n", $name, $age); MCE->printf($fh, "%s: %d\n", $name, $age); MCE->printf("%s: %d\n", $name, $age); MCE->print(\*STDERR, "$error_msg\n"); MCE->print($fh, $log_msg."\n"); MCE->print("$output_msg\n"); MCE->say(\*STDERR, $error_msg); MCE->say($fh, $log_msg); MCE->say($output_msg); Caveat: Use the following syntax when passing a reference not a glob or file handle. Otherwise, MCE will error indicating the first argument is not a glob reference. MCE->print(\*STDOUT, \@array, "\n"); MCE->print("", \@array, "\n"); ## ok =head2 $mce->relay ( sub { code } ) =head2 $mce->relay_recv ( void ) Described in L. =head2 $mce->sendto ( $to, $arg1, ... ) The sendto method is called by workers for serializing data to standard output, standard error, or end of file. The action is done by the manager process. Release 1.00x supported 1 data argument, not more. MCE->sendto('file', \@array, '/path/to/file'); MCE->sendto('file', \$scalar, '/path/to/file'); MCE->sendto('file', $scalar, '/path/to/file'); MCE->sendto('STDERR', \@array); MCE->sendto('STDERR', \$scalar); MCE->sendto('STDERR', $scalar); MCE->sendto('STDOUT', \@array); MCE->sendto('STDOUT', \$scalar); MCE->sendto('STDOUT', $scalar); Release 1.100 added the ability to pass multiple arguments. Notice the syntax change for sending to a file. Passing a reference to an array is no longer necessary. MCE->sendto('file:/path/to/file', $arg1 [, $arg2, ... ]); MCE->sendto('STDERR', $arg1 [, $arg2, ... ]); MCE->sendto('STDOUT', $arg1 [, $arg2, ... ]); MCE->sendto('STDOUT', @a, "\n", %h, "\n", $s, "\n"); To retain 1.00x compatibility, sendto outputs the content when a single data reference is specified. Otherwise, the reference for \@array or \$scalar is shown in 1.500, not the content. MCE->sendto('STDERR', \@array); ## 1.00x behavior, content MCE->sendto('STDOUT', \$scalar); MCE->sendto('file:/path/to/file', \@array); ## Output matches the print statement MCE->sendto(\*STDERR, \@array); ## 1.500 behavior, reference MCE->sendto(\*STDOUT, \$scalar); MCE->sendto($fh, \@array); MCE->sendto('STDOUT', \@array, "\n", \$scalar, "\n"); print {*STDOUT} \@array, "\n", \$scalar, "\n"; MCE 1.500 added support for sending to a glob reference, file descriptor, and file handle. MCE->sendto(\*STDERR, "foo\n", \@array, \$scalar, "\n"); MCE->sendto('fd:2', "foo\n", \@array, \$scalar, "\n"); MCE->sendto($fh, "foo\n", \@array, \$scalar, "\n"); =head2 $mce->sync ( void ) A barrier sync operation means any worker must stop at this point until all workers reach this barrier. Barrier syncing is useful for many computer algorithms. Barrier synchronization is supported for task 0 only or omitting user_tasks. All workers assigned task_id 0 must call sync whenever barrier syncing. use MCE; sub user_func { my ($mce) = @_; my $wid = MCE->wid; MCE->sendto("STDOUT", "a: $wid\n"); ## MCE 1.0+ MCE->sync; MCE->sendto(\*STDOUT, "b: $wid\n"); ## MCE 1.5+ MCE->sync; MCE->print("c: $wid\n"); ## MCE 1.5+ MCE->sync; return; } my $mce = MCE->new( max_workers => 4, user_func => \&user_func )->run; -- Output (without barrier synchronization) a: 1 a: 2 b: 1 b: 2 c: 1 c: 2 a: 3 b: 3 c: 3 a: 4 b: 4 c: 4 -- Output (with barrier synchronization) a: 1 a: 2 a: 4 a: 3 b: 2 b: 1 b: 3 b: 4 c: 1 c: 4 c: 2 c: 3 Consider the following example. The MCE->sync operation is done inside a loop along with MCE->do. A stall may occur for workers calling sync the 2nd or 3rd time while other workers are sending results via MCE->do or MCE->sendto. It requires another semaphore lock in MCE to solve this which was not done in order to keep resources low. Therefore, please keep this in mind when mixing MCE->sync with MCE->do or output serialization methods inside a loop. sub user_func { my ($mce) = @_; my @result; for (1 .. 3) { ... compute algorithm ... MCE->sync; ... compute algorithm ... MCE->sync; MCE->do('aggregate_result', \@result); ## or MCE->sendto MCE->sync; ## The sync operation is also needed here to ## prevent MCE from stalling. } } =head2 $mce->yield ( void ) There may be on occasion when the MCE driven app is too fast. The interval option combined with the yield method, both introduced with MCE 1.5, allows one to throttle the app. It adds a "grace" factor to the design. A use case is an app configured with 100 workers running on a 24 logical way box. Data is polled from a database containing over 2.5 million rows. Workers chunk away at 300 rows per chunk performing SNMP gets (300 sockets per worker) polling 25 metrics from each device. With this scenario, the load on the box may rise beyond 90+. In addition, IP_Tables may reach its contention point causing the entire application to fail. The scenario above is solved by simply having workers yield among themselves in a synchronized fashion. A delay of 0.007 seconds between intervals is all that's needed. The load on the box will hover between 23 ~ 27 for the duration of the run. Polling completes in under 17 minutes time. This is quite fast considering the app polls 62.5 million metrics combined. The math equates to 3,676,470 per minute or rather 61,275 per second from a single box. ## Both max_nodes and node_id are optional (default 1). interval => { delay => 0.007, max_nodes => $max_nodes, node_id => $node_id } A 4 node setup can poll 10 million devices without the additional overhead of a distribution agent. The difference between the 4 nodes are simply node_id and the where clause used to query the database. The mac addresses are random such that the data divides equally to any power of 2. The distribution key lies in the mac address itself. In fact, the 2nd character from the right is sufficient for maximizing on the power of randomness for equal distribution. Query NodeID 1: ... AND substr(MAC, -2, 1) IN ('0', '1', '2', '3') Query NodeID 2: ... AND substr(MAC, -2, 1) IN ('4', '5', '6', '7') Query NodeID 3: ... AND substr(MAC, -2, 1) IN ('8', '9', 'A', 'B') Query NodeID 4: ... AND substr(MAC, -2, 1) IN ('C', 'D', 'E', 'F') Below, the user_tasks is configured to simulate 4 nodes. This demonstration uses 2 workers to minimize the output size. Input is from the sequence option. use Time::HiRes qw(time); use MCE; my $d = shift || 0.1; local $| = 1; sub create_task { my ($node_id) = @_; my $seq_size = 6; my $seq_start = ($node_id - 1) * $seq_size + 1; my $seq_end = $seq_start + $seq_size - 1; return { max_workers => 2, sequence => [ $seq_start, $seq_end ], interval => { delay => $d, max_nodes => 4, node_id => $node_id } }; } sub user_begin { my ($mce, $task_id, $task_name) = @_; ## The yield method causes this worker to wait for its next time ## interval slot before running. Yield has no effect without the ## 'interval' option. ## Yielding is beneficial inside a user_begin block. A use case ## is staggering database connections among workers in order ## to not impact the DB server. MCE->yield; MCE->printf( "Node %2d: %0.5f -- Worker %2d: %12s -- Started\n", MCE->task_id + 1, time, MCE->task_wid, '' ); return; } { my $prev_time = time; sub user_func { my ($mce, $seq_n, $chunk_id) = @_; ## Yield simply waits for the next time interval. MCE->yield; ## Calculate how long this worker has waited. my $curr_time = time; my $time_waited = $curr_time - $prev_time; $prev_time = $curr_time; MCE->printf( "Node %2d: %0.5f -- Worker %2d: %12.5f -- Seq_N %3d\n", MCE->task_id + 1, time, MCE->task_wid, $time_waited, $seq_n ); return; } } ## Simulate a 4 node environment passing node_id to create_task. print "Node_ID Current_Time Worker_ID Time_Waited Comment\n"; MCE->new( user_begin => \&user_begin, user_func => \&user_func, user_tasks => [ create_task(1), create_task(2), create_task(3), create_task(4) ] )->run; -- Output (notice Current_Time below, stays 0.10 apart) Node_ID Current_Time Worker_ID Time_Waited Comment Node 1: 1374807976.74634 -- Worker 1: -- Started Node 2: 1374807976.84634 -- Worker 1: -- Started Node 3: 1374807976.94638 -- Worker 1: -- Started Node 4: 1374807977.04639 -- Worker 1: -- Started Node 1: 1374807977.14634 -- Worker 2: -- Started Node 2: 1374807977.24640 -- Worker 2: -- Started Node 3: 1374807977.34649 -- Worker 2: -- Started Node 4: 1374807977.44657 -- Worker 2: -- Started Node 1: 1374807977.54636 -- Worker 1: 0.90037 -- Seq_N 1 Node 2: 1374807977.64638 -- Worker 1: 1.00040 -- Seq_N 7 Node 3: 1374807977.74642 -- Worker 1: 1.10043 -- Seq_N 13 Node 4: 1374807977.84643 -- Worker 1: 1.20045 -- Seq_N 19 Node 1: 1374807977.94636 -- Worker 2: 1.30037 -- Seq_N 2 Node 2: 1374807978.04638 -- Worker 2: 1.40040 -- Seq_N 8 Node 3: 1374807978.14641 -- Worker 2: 1.50042 -- Seq_N 14 Node 4: 1374807978.24644 -- Worker 2: 1.60045 -- Seq_N 20 Node 1: 1374807978.34628 -- Worker 1: 0.79996 -- Seq_N 3 Node 2: 1374807978.44631 -- Worker 1: 0.79996 -- Seq_N 9 Node 3: 1374807978.54634 -- Worker 1: 0.79996 -- Seq_N 15 Node 4: 1374807978.64636 -- Worker 1: 0.79997 -- Seq_N 21 Node 1: 1374807978.74628 -- Worker 2: 0.79996 -- Seq_N 4 Node 2: 1374807978.84632 -- Worker 2: 0.79997 -- Seq_N 10 Node 3: 1374807978.94634 -- Worker 2: 0.79996 -- Seq_N 16 Node 4: 1374807979.04636 -- Worker 2: 0.79996 -- Seq_N 22 Node 1: 1374807979.14628 -- Worker 1: 0.80001 -- Seq_N 5 Node 2: 1374807979.24631 -- Worker 1: 0.80000 -- Seq_N 11 Node 3: 1374807979.34634 -- Worker 1: 0.80001 -- Seq_N 17 Node 4: 1374807979.44636 -- Worker 1: 0.80000 -- Seq_N 23 Node 1: 1374807979.54628 -- Worker 2: 0.80000 -- Seq_N 6 Node 2: 1374807979.64631 -- Worker 2: 0.80000 -- Seq_N 12 Node 3: 1374807979.74633 -- Worker 2: 0.80000 -- Seq_N 18 Node 4: 1374807979.84636 -- Worker 2: 0.80000 -- Seq_N 24 The interval.pl example above is included with MCE. =head1 INDEX L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.810/lib/MCE/Queue.pm0000644000175000017500000016336313022712412013731 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## Hybrid (normal and priority) queues. ## ############################################################################### package MCE::Queue; use strict; use warnings; no warnings qw( threads recursion uninitialized ); our $VERSION = '1.810'; ## no critic (Subroutines::ProhibitExplicitReturnUndef) ## no critic (TestingAndDebugging::ProhibitNoStrict) use Scalar::Util qw( looks_like_number ); use MCE::Util qw( $LF ); use bytes; ############################################################################### ## ---------------------------------------------------------------------------- ## Import routine. ## ############################################################################### our ($HIGHEST,$LOWEST, $FIFO,$LIFO, $LILO,$FILO) = (1,0, 1,0, 1,0); my ($_def, $_imported) = ({}); sub import { my ($_class, $_pkg) = (shift, caller); ## Process module arguments. my $_p = $_def->{$_pkg} = { AWAIT => 0, FAST => 0, PORDER => $HIGHEST, TYPE => $FIFO, }; while (my $_argument = shift) { my $_arg = lc $_argument; if ( $_arg eq 'await' ) { _croak('Error: (AWAIT) must be 1 or 0') if (!defined $_[0] || ($_[0] ne '1' && $_[0] ne '0')); $_p->{AWAIT} = shift; next; } if ( $_arg eq 'fast' ) { _croak('Error: (FAST) must be 1 or 0') if (!defined $_[0] || ($_[0] ne '1' && $_[0] ne '0')); $_p->{FAST} = shift; next; } if ( $_arg eq 'porder' ) { _croak('Error: (PORDER) must be 1 or 0') if (!defined $_[0] || ($_[0] ne '1' && $_[0] ne '0')); $_p->{PORDER} = shift; next; } if ( $_arg eq 'type' ) { _croak('Error: (TYPE) must be 1 or 0') if (!defined $_[0] || ($_[0] ne '1' && $_[0] ne '0')); $_p->{TYPE} = shift; next; } _croak("Error: ($_argument) invalid module option"); } return if $_imported++; ## Define public methods to internal methods. no strict 'refs'; no warnings 'redefine'; if (defined $MCE::VERSION && MCE->wid == 0) { _mce_m_init(); } else { *{ 'MCE::Queue::await' } = \&_await; *{ 'MCE::Queue::clear' } = \&_clear; *{ 'MCE::Queue::enqueue' } = \&_enqueue; *{ 'MCE::Queue::enqueuep' } = \&_enqueuep; *{ 'MCE::Queue::dequeue' } = \&_dequeue; *{ 'MCE::Queue::dequeue_nb' } = \&_dequeue; *{ 'MCE::Queue::pending' } = \&_pending; *{ 'MCE::Queue::insert' } = \&_insert; *{ 'MCE::Queue::insertp' } = \&_insertp; *{ 'MCE::Queue::peek' } = \&_peek; *{ 'MCE::Queue::peekp' } = \&_peekp; *{ 'MCE::Queue::peekh' } = \&_peekh; *{ 'MCE::Queue::heap' } = \&_heap; } return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Define constants & variables. ## ############################################################################### use constant { MAX_DQ_DEPTH => 192, # Maximum dequeue notifications OUTPUT_W_QUE => 'W~QUE', # Await from the queue OUTPUT_C_QUE => 'C~QUE', # Clear the queue OUTPUT_A_QUE => 'A~QUE', # Enqueue into queue (array) OUTPUT_A_QUP => 'A~QUP', # Enqueue into queue (array (p)) OUTPUT_S_QUE => 'S~QUE', # Enqueue into queue (scalar) OUTPUT_S_QUP => 'S~QUP', # Enqueue into queue (scalar (p)) OUTPUT_D_QUE => 'D~QUE', # Dequeue from queue (blocking) OUTPUT_D_QUN => 'D~QUN', # Dequeue from queue (non-blocking) OUTPUT_N_QUE => 'N~QUE', # Return the number of items OUTPUT_I_QUE => 'I~QUE', # Insert into queue OUTPUT_I_QUP => 'I~QUP', # Insert into queue (p) OUTPUT_P_QUE => 'P~QUE', # Peek into queue OUTPUT_P_QUP => 'P~QUP', # Peek into queue (p) OUTPUT_P_QUH => 'P~QUH', # Peek into heap OUTPUT_H_QUE => 'H~QUE' # Return the heap }; ## Attributes used internally. ## _qr_sock _qw_sock _datp _datq _heap _id _init_pid _nb_flag _porder _type ## _ar_sock _aw_sock _asem _tsem my $_has_threads = $INC{'threads.pm'} ? 1 : 0; my $_tid = $_has_threads ? threads->tid() : 0; my %_valid_fields_new = map { $_ => 1 } qw( await fast gather porder queue type ); my $_all = {}; my $_qid = 0; sub CLONE { $_tid = threads->tid() if $_has_threads; } sub DESTROY { my ($_Q) = @_; my $_pid = $_has_threads ? $$ .'.'. $_tid : $$; undef $_Q->{_datp}, undef $_Q->{_datq}, undef $_Q->{_heap}; delete $_all->{ $_Q->{_id} } if exists $_Q->{_id}; MCE::Util::_destroy_socks($_Q, qw(_aw_sock _ar_sock _qw_sock _qr_sock)) if exists $_Q->{_init_pid} && $_Q->{_init_pid} eq $_pid; return; } ############################################################################### ## ---------------------------------------------------------------------------- ## New instance instantiation. ## ############################################################################### sub new { my ($_class, %_argv) = @_; my $_pkg = caller; @_ = (); my $_Q = {}; bless($_Q, ref($_class) || $_class); for my $_p (keys %_argv) { _croak("Queue: ($_p) is not a valid constructor argument") unless (exists $_valid_fields_new{$_p}); } $_Q->{_asem} = 0; # Semaphore count variable for the ->await method $_Q->{_datp} = {}; # Priority data { p1 => [ ], p2 => [ ], pN => [ ] } $_Q->{_heap} = []; # Priority heap [ pN, p2, p1 ] in heap order # fyi, _datp will always dequeue before _datq $_Q->{_await} = (exists $_argv{await} && defined $_argv{await}) ? $_argv{await} : $_def->{$_pkg}{AWAIT} || 0; $_Q->{_fast} = (exists $_argv{fast} && defined $_argv{fast}) ? $_argv{fast} : $_def->{$_pkg}{FAST} || 0; $_Q->{_porder} = (exists $_argv{porder} && defined $_argv{porder}) ? $_argv{porder} : $_def->{$_pkg}{PORDER} || $HIGHEST; $_Q->{_type} = (exists $_argv{type} && defined $_argv{type}) ? $_argv{type} : $_def->{$_pkg}{TYPE} || $FIFO; ## ------------------------------------------------------------------------- _croak('Queue: (await) must be 1 or 0') if ($_Q->{_await} ne '1' && $_Q->{_await} ne '0'); _croak('Queue: (fast) must be 1 or 0') if ($_Q->{_fast} ne '1' && $_Q->{_fast} ne '0'); _croak('Queue: (porder) must be 1 or 0') if ($_Q->{_porder} ne '1' && $_Q->{_porder} ne '0'); _croak('Queue: (type) must be 1 or 0') if ($_Q->{_type} ne '1' && $_Q->{_type} ne '0'); if (exists $_argv{queue}) { _croak('Queue: (queue) is not an ARRAY reference') if (ref $_argv{queue} ne 'ARRAY'); $_Q->{_datq} = $_argv{queue}; } else { $_Q->{_datq} = []; } if (exists $_argv{gather}) { _croak('Queue: (gather) is not a CODE reference') if (ref $_argv{gather} ne 'CODE'); $_Q->{gather} = $_argv{gather}; } ## ------------------------------------------------------------------------- if (defined $MCE::VERSION) { $_Q->{_init_pid} = $_has_threads ? $$ .'.'. $_tid : $$; $_Q->{_id} = ++$_qid; $_all->{$_qid} = $_Q; $_Q->{_dsem} = 0 if ($_Q->{_fast}); MCE::Util::_sock_pair($_Q, qw(_qr_sock _qw_sock)); MCE::Util::_sock_pair($_Q, qw(_ar_sock _aw_sock)) if $_Q->{_await}; if (exists $_argv{queue} && scalar @{ $_argv{queue} }) { syswrite $_Q->{_qw_sock}, $LF; } } return $_Q; } ############################################################################### ## ---------------------------------------------------------------------------- ## Await and clear methods. ## ############################################################################### sub _await { return; } sub _clear { my ($_Q) = @_; %{ $_Q->{_datp} } = (); @{ $_Q->{_datq} } = (); @{ $_Q->{_heap} } = (); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Enqueue methods. ## ############################################################################### ## Add items to the tail of the queue. sub _enqueue { my $_Q = shift; ## Append item(s) into the queue. push @{ $_Q->{_datq} }, @_; return; } ## Add items to the tail of the queue with priority level. sub _enqueuep { my ($_Q, $_p) = (shift, shift); _croak('Queue: (enqueuep priority) is not an integer') if (!looks_like_number($_p) || int($_p) != $_p); return unless (scalar @_); ## Enlist priority into the heap. if (!exists $_Q->{_datp}->{$_p} || @{ $_Q->{_datp}->{$_p} } == 0) { unless (scalar @{ $_Q->{_heap} }) { push @{ $_Q->{_heap} }, $_p; } elsif ($_Q->{_porder}) { $_Q->_heap_insert_high($_p); } else { $_Q->_heap_insert_low($_p); } } ## Append item(s) into the queue. push @{ $_Q->{_datp}->{$_p} }, @_; return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Dequeue and pending methods. ## ############################################################################### ## Return item(s) from the queue. sub _dequeue { my ($_Q, $_cnt) = @_; if (defined $_cnt && $_cnt ne '1') { _croak('Queue: (dequeue count argument) is not valid') if (!looks_like_number($_cnt) || int($_cnt) != $_cnt || $_cnt < 1); my @_items; push(@_items, $_Q->_dequeue()) for (1 .. $_cnt); return @_items; } ## Return item from the non-priority queue. unless (scalar @{ $_Q->{_heap} }) { return ($_Q->{_type}) ? shift @{ $_Q->{_datq} } : pop @{ $_Q->{_datq} }; } my $_p = $_Q->{_heap}->[0]; ## Delist priority from the heap when 1 item remains. shift @{ $_Q->{_heap} } if (@{ $_Q->{_datp}->{$_p} } == 1); ## Return item from the priority queue. return ($_Q->{_type}) ? shift @{ $_Q->{_datp}->{$_p} } : pop @{ $_Q->{_datp}->{$_p} }; } ## Return the number of items in the queue. sub _pending { my $_pending = 0; my ($_Q) = @_; if (scalar @{ $_Q->{_heap} }) { for my $_h (@{ $_Q->{_heap} }) { $_pending += @{ $_Q->{_datp}->{$_h} }; } } $_pending += @{ $_Q->{_datq} }; return $_pending; } ############################################################################### ## ---------------------------------------------------------------------------- ## Insert methods. ## ############################################################################### ## Insert items anywhere into the queue. sub _insert { my ($_Q, $_i) = (shift, shift); _croak('Queue: (insert index) is not an integer') if (!looks_like_number($_i) || int($_i) != $_i); return unless (scalar @_); if (abs($_i) > scalar @{ $_Q->{_datq} }) { if ($_i >= 0) { if ($_Q->{_type}) { push @{ $_Q->{_datq} }, @_; } else { unshift @{ $_Q->{_datq} }, @_; } } else { if ($_Q->{_type}) { unshift @{ $_Q->{_datq} }, @_; } else { push @{ $_Q->{_datq} }, @_; } } } else { if (!$_Q->{_type}) { $_i = ($_i >= 0) ? scalar(@{ $_Q->{_datq} }) - $_i : abs($_i); } splice @{ $_Q->{_datq} }, $_i, 0, @_; } return; } ## Insert items anywhere into the queue with priority level. sub _insertp { my ($_Q, $_p, $_i) = (shift, shift, shift); _croak('Queue: (insertp priority) is not an integer') if (!looks_like_number($_p) || int($_p) != $_p); _croak('Queue: (insertp index) is not an integer') if (!looks_like_number($_i) || int($_i) != $_i); return unless (scalar @_); if (exists $_Q->{_datp}->{$_p} && scalar @{ $_Q->{_datp}->{$_p} }) { if (abs($_i) > scalar @{ $_Q->{_datp}->{$_p} }) { if ($_i >= 0) { if ($_Q->{_type}) { push @{ $_Q->{_datp}->{$_p} }, @_; } else { unshift @{ $_Q->{_datp}->{$_p} }, @_; } } else { if ($_Q->{_type}) { unshift @{ $_Q->{_datp}->{$_p} }, @_; } else { push @{ $_Q->{_datp}->{$_p} }, @_; } } } else { if (!$_Q->{_type}) { $_i = ($_i >=0) ? scalar(@{ $_Q->{_datp}->{$_p} }) - $_i : abs($_i); } splice @{ $_Q->{_datp}->{$_p} }, $_i, 0, @_; } } else { $_Q->_enqueuep($_p, @_); } return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Peek and heap methods. ## ## Below, do not change 'return undef' statements to 'return'. ## ############################################################################### ## Return an item without removing it from the queue. sub _peek { my ($_Q, $_i) = @_; if ($_i) { _croak('Queue: (peek index) is not an integer') if (!looks_like_number($_i) || int($_i) != $_i); } else { $_i = 0 } return undef if (abs($_i) > scalar @{ $_Q->{_datq} }); if (!$_Q->{_type}) { $_i = ($_i >= 0) ? scalar(@{ $_Q->{_datq} }) - ($_i + 1) : abs($_i + 1); } return $_Q->{_datq}->[$_i]; } ## Return an item without removing it from the queue with priority level. sub _peekp { my ($_Q, $_p, $_i) = @_; if ($_i) { _croak('Queue: (peekp index) is not an integer') if (!looks_like_number($_i) || int($_i) != $_i); } else { $_i = 0 } _croak('Queue: (peekp priority) is not an integer') if (!looks_like_number($_p) || int($_p) != $_p); return undef unless (exists $_Q->{_datp}->{$_p}); return undef if (abs($_i) > scalar @{ $_Q->{_datp}->{$_p} }); if (!$_Q->{_type}) { $_i = ($_i >= 0) ? scalar(@{ $_Q->{_datp}->{$_p} }) - ($_i + 1) : abs($_i + 1); } return $_Q->{_datp}->{$_p}->[$_i]; } ## Return a priority level without removing it from the heap. sub _peekh { my ($_Q, $_i) = @_; if ($_i) { _croak('Queue: (peekh index) is not an integer') if (!looks_like_number($_i) || int($_i) != $_i); } else { $_i = 0 } return undef if (abs($_i) > scalar @{ $_Q->{_heap} }); return $_Q->{_heap}->[$_i]; } ## Return a list of priority levels in the heap. sub _heap { return @{ shift->{_heap} }; } ############################################################################### ## ---------------------------------------------------------------------------- ## Internal methods. ## ############################################################################### sub _croak { unless (defined $MCE::VERSION) { $\ = undef; require Carp; goto &Carp::croak; } else { goto &MCE::_croak; } } ## Helper method for getting the reference to the underlying array. ## Use with test scripts for comparing data only (not a public API). sub _get_aref { my ($_Q, $_p) = @_; return if (defined $MCE::VERSION && !defined $MCE::MCE->{_wid}); return if (defined $MCE::MCE && $MCE::MCE->{_wid}); if (defined $_p) { _croak('Queue: (get_aref priority) is not an integer') if (!looks_like_number($_p) || int($_p) != $_p); return undef unless (exists $_Q->{_datp}->{$_p}); return $_Q->{_datp}->{$_p}; } return $_Q->{_datq}; } ## A quick method for just wanting to know if the queue has pending data. sub _has_data { return ( scalar @{ $_[0]->{_datq} } || scalar @{ $_[0]->{_heap} } ) ? 1 : 0; } ## Insert priority into the heap. A lower priority level comes first. sub _heap_insert_low { my ($_Q, $_p) = @_; ## Insert priority at the head of the heap. if ($_p < $_Q->{_heap}->[0]) { unshift @{ $_Q->{_heap} }, $_p; } ## Insert priority at the end of the heap. elsif ($_p > $_Q->{_heap}->[-1]) { push @{ $_Q->{_heap} }, $_p; } ## Insert priority through binary search. else { my $_lower = 0; my $_upper = @{ $_Q->{_heap} }; while ($_lower < $_upper) { my $_midpoint = $_lower + (($_upper - $_lower) >> 1); if ($_p > $_Q->{_heap}->[$_midpoint]) { $_lower = $_midpoint + 1; } else { $_upper = $_midpoint; } } ## Insert priority into the heap. splice @{ $_Q->{_heap} }, $_lower, 0, $_p; } return; } ## Insert priority into the heap. A higher priority level comes first. sub _heap_insert_high { my ($_Q, $_p) = @_; ## Insert priority at the head of the heap. if ($_p > $_Q->{_heap}->[0]) { unshift @{ $_Q->{_heap} }, $_p; } ## Insert priority at the end of the heap. elsif ($_p < $_Q->{_heap}->[-1]) { push @{ $_Q->{_heap} }, $_p; } ## Insert priority through binary search. else { my $_lower = 0; my $_upper = @{ $_Q->{_heap} }; while ($_lower < $_upper) { my $_midpoint = $_lower + (($_upper - $_lower) >> 1); if ($_p < $_Q->{_heap}->[$_midpoint]) { $_lower = $_midpoint + 1; } else { $_upper = $_midpoint; } } ## Insert priority into the heap. splice @{ $_Q->{_heap} }, $_lower, 0, $_p; } return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Output routines for the manager process. ## ############################################################################### { my ($_MCE, $_DAU_R_SOCK_REF, $_DAU_R_SOCK, $_cnt, $_i, $_id); my ($_len, $_p, $_t, $_Q, $_pending); my %_output_function = ( OUTPUT_W_QUE.$LF => sub { # Await from the queue $_DAU_R_SOCK = ${ $_DAU_R_SOCK_REF }; chomp($_id = <$_DAU_R_SOCK>), chomp($_t = <$_DAU_R_SOCK>); $_Q = $_all->{$_id}; $_Q->{_tsem} = $_t; if ($_Q->_pending() <= $_t) { syswrite $_Q->{_aw_sock}, $LF; } else { $_Q->{_asem} += 1; } print {$_DAU_R_SOCK} $LF; return; }, OUTPUT_C_QUE.$LF => sub { # Clear the queue $_DAU_R_SOCK = ${ $_DAU_R_SOCK_REF }; chomp($_id = <$_DAU_R_SOCK>); $_Q = $_all->{$_id}; if ($_Q->_has_data()) { sysread $_Q->{_qr_sock}, my($_buf), 1; } $_Q->_clear(); print {$_DAU_R_SOCK} $LF; return; }, ## ---------------------------------------------------------------------- OUTPUT_A_QUE.$LF => sub { # Enqueue into queue (A) $_DAU_R_SOCK = ${ $_DAU_R_SOCK_REF }; chomp($_id = <$_DAU_R_SOCK>), chomp($_len = <$_DAU_R_SOCK>); read $_DAU_R_SOCK, my($_buf), $_len; $_Q = $_all->{$_id}; if ($_Q->{gather}) { local $_ = $_MCE->{thaw}($_buf); $_Q->{gather}($_Q, @{ $_ }); } else { if (!$_Q->{_nb_flag} && !$_Q->_has_data()) { syswrite $_Q->{_qw_sock}, $LF; } push @{ $_Q->{_datq} }, @{ $_MCE->{thaw}($_buf) }; } return; }, OUTPUT_A_QUP.$LF => sub { # Enqueue into queue (A,p) $_DAU_R_SOCK = ${ $_DAU_R_SOCK_REF }; chomp($_id = <$_DAU_R_SOCK>), chomp($_p = <$_DAU_R_SOCK>), chomp($_len = <$_DAU_R_SOCK>); read $_DAU_R_SOCK, my($_buf), $_len; $_Q = $_all->{$_id}; if (!$_Q->{_nb_flag} && !$_Q->_has_data()) { syswrite $_Q->{_qw_sock}, $LF; } $_Q->_enqueuep($_p, @{ $_MCE->{thaw}($_buf) }); return; }, ## ---------------------------------------------------------------------- OUTPUT_S_QUE.$LF => sub { # Enqueue into queue (S) $_DAU_R_SOCK = ${ $_DAU_R_SOCK_REF }; local $_; chomp($_id = <$_DAU_R_SOCK>), chomp($_len = <$_DAU_R_SOCK>); read $_DAU_R_SOCK, $_, $_len; $_Q = $_all->{$_id}; if ($_Q->{gather}) { $_Q->{gather}($_Q, $_); } else { if (!$_Q->{_nb_flag} && !$_Q->_has_data()) { syswrite $_Q->{_qw_sock}, $LF; } push @{ $_Q->{_datq} }, $_; } return; }, OUTPUT_S_QUP.$LF => sub { # Enqueue into queue (S,p) $_DAU_R_SOCK = ${ $_DAU_R_SOCK_REF }; chomp($_id = <$_DAU_R_SOCK>), chomp($_p = <$_DAU_R_SOCK>), chomp($_len = <$_DAU_R_SOCK>); read $_DAU_R_SOCK, my($_buf), $_len; $_Q = $_all->{$_id}; if (!$_Q->{_nb_flag} && !$_Q->_has_data()) { syswrite $_Q->{_qw_sock}, $LF; } $_Q->_enqueuep($_p, $_buf); return; }, ## ---------------------------------------------------------------------- OUTPUT_D_QUE.$LF => sub { # Dequeue from queue (B) $_DAU_R_SOCK = ${ $_DAU_R_SOCK_REF }; chomp($_id = <$_DAU_R_SOCK>), chomp($_cnt = <$_DAU_R_SOCK>); $_cnt = 0 if ($_cnt == 1); $_Q = $_all->{$_id}; my (@_items, $_buf); if ($_cnt) { push(@_items, $_Q->_dequeue()) for (1 .. $_cnt); } else { $_buf = $_Q->_dequeue(); } if ($_Q->{_fast}) { ## The 'fast' option may reduce wait time, thus run faster if ($_Q->{_dsem} <= 1) { $_pending = $_Q->_pending(); $_pending = int($_pending / $_cnt) if ($_cnt); if ($_pending) { $_pending = MAX_DQ_DEPTH if ($_pending > MAX_DQ_DEPTH); for (1 .. $_pending) { syswrite $_Q->{_qw_sock}, $LF } } $_Q->{_dsem} = $_pending; } else { $_Q->{_dsem} -= 1; } } else { ## Otherwise, never to exceed one byte in the channel if ($_Q->_has_data()) { syswrite $_Q->{_qw_sock}, $LF } } if ($_cnt) { if (defined $_items[0]) { $_buf = $_MCE->{freeze}(\@_items); print {$_DAU_R_SOCK} length($_buf).$LF, $_buf; } else { print {$_DAU_R_SOCK} '-1'.$LF; } } elsif (defined $_buf) { if (!ref $_buf) { $_buf .= '0'; } else { $_buf = $_MCE->{freeze}($_buf).'1'; } print {$_DAU_R_SOCK} length($_buf).$LF, $_buf; } else { print {$_DAU_R_SOCK} '-1'.$LF; } if ($_Q->{_await} && $_Q->{_asem} && $_Q->_pending() <= $_Q->{_tsem}) { for (1 .. $_Q->{_asem}) { syswrite $_Q->{_aw_sock}, $LF } $_Q->{_asem} = 0; } $_Q->{_nb_flag} = 0; return; }, OUTPUT_D_QUN.$LF => sub { # Dequeue from queue (NB) $_DAU_R_SOCK = ${ $_DAU_R_SOCK_REF }; chomp($_id = <$_DAU_R_SOCK>), chomp($_cnt = <$_DAU_R_SOCK>); $_Q = $_all->{$_id}; if ($_cnt == 1) { my $_buf = $_Q->_dequeue(); if (defined $_buf) { if (!ref $_buf) { $_buf .= '0'; } else { $_buf = $_MCE->{freeze}($_buf).'1'; } print {$_DAU_R_SOCK} length($_buf).$LF, $_buf; } else { print {$_DAU_R_SOCK} '-1'.$LF; } } else { my @_items; push(@_items, $_Q->_dequeue()) for (1 .. $_cnt); if (defined $_items[0]) { my $_buf = $_MCE->{freeze}(\@_items); print {$_DAU_R_SOCK} length($_buf).$LF, $_buf; } else { print {$_DAU_R_SOCK} '-1'.$LF; } } if ($_Q->{_await} && $_Q->{_asem} && $_Q->_pending() <= $_Q->{_tsem}) { for (1 .. $_Q->{_asem}) { syswrite $_Q->{_aw_sock}, $LF } $_Q->{_asem} = 0; } $_Q->{_nb_flag} = 1; return; }, ## ---------------------------------------------------------------------- OUTPUT_N_QUE.$LF => sub { # Return number of items $_DAU_R_SOCK = ${ $_DAU_R_SOCK_REF }; chomp($_id = <$_DAU_R_SOCK>); print {$_DAU_R_SOCK} $_all->{$_id}->_pending().$LF; return; }, OUTPUT_I_QUE.$LF => sub { # Insert into queue $_DAU_R_SOCK = ${ $_DAU_R_SOCK_REF }; chomp($_id = <$_DAU_R_SOCK>), chomp($_i = <$_DAU_R_SOCK>), chomp($_len = <$_DAU_R_SOCK>); read $_DAU_R_SOCK, my($_buf), $_len; $_Q = $_all->{$_id}; if (!$_Q->{_nb_flag} && !$_Q->_has_data()) { syswrite $_Q->{_qw_sock}, $LF; } if (chop $_buf) { $_Q->_insert($_i, @{ $_MCE->{thaw}($_buf) }); } else { $_Q->_insert($_i, $_buf); } return; }, OUTPUT_I_QUP.$LF => sub { # Insert into queue (p) $_DAU_R_SOCK = ${ $_DAU_R_SOCK_REF }; chomp($_id = <$_DAU_R_SOCK>), chomp($_p = <$_DAU_R_SOCK>), chomp($_i = <$_DAU_R_SOCK>), chomp($_len = <$_DAU_R_SOCK>); read $_DAU_R_SOCK, my($_buf), $_len; $_Q = $_all->{$_id}; if (!$_Q->{_nb_flag} && !$_Q->_has_data()) { syswrite $_Q->{_qw_sock}, $LF; } if (chop $_buf) { $_Q->_insertp($_p, $_i, @{ $_MCE->{thaw}($_buf) }); } else { $_Q->_insertp($_p, $_i, $_buf); } return; }, ## ---------------------------------------------------------------------- OUTPUT_P_QUE.$LF => sub { # Peek into queue my $_buf; $_DAU_R_SOCK = ${ $_DAU_R_SOCK_REF }; chomp($_id = <$_DAU_R_SOCK>), chomp($_i = <$_DAU_R_SOCK>); $_Q = $_all->{$_id}; $_buf = $_Q->_peek($_i); unless (defined $_buf) { print {$_DAU_R_SOCK} '-1'.$LF; } else { if (ref $_buf) { $_buf = $_MCE->{freeze}($_buf).'1'; } else { $_buf .= '0'; } print {$_DAU_R_SOCK} length($_buf).$LF, $_buf; } return; }, OUTPUT_P_QUP.$LF => sub { # Peek into queue (p) my $_buf; $_DAU_R_SOCK = ${ $_DAU_R_SOCK_REF }; chomp($_id = <$_DAU_R_SOCK>), chomp($_p = <$_DAU_R_SOCK>), chomp($_i = <$_DAU_R_SOCK>); $_Q = $_all->{$_id}; $_buf = $_Q->_peekp($_p, $_i); unless (defined $_buf) { print {$_DAU_R_SOCK} '-1'.$LF; } else { if (ref $_buf) { $_buf = $_MCE->{freeze}($_buf).'1'; } else { $_buf .= '0'; } print {$_DAU_R_SOCK} length($_buf).$LF, $_buf; } return; }, OUTPUT_P_QUH.$LF => sub { # Peek into heap my $_buf; $_DAU_R_SOCK = ${ $_DAU_R_SOCK_REF }; chomp($_id = <$_DAU_R_SOCK>), chomp($_i = <$_DAU_R_SOCK>); $_Q = $_all->{$_id}; $_buf = $_Q->_peekh($_i); unless (defined $_buf) { print {$_DAU_R_SOCK} '-1'.$LF; } else { print {$_DAU_R_SOCK} length($_buf).$LF, $_buf; } return; }, OUTPUT_H_QUE.$LF => sub { # Return the heap my $_buf; $_DAU_R_SOCK = ${ $_DAU_R_SOCK_REF }; chomp($_id = <$_DAU_R_SOCK>); $_Q = $_all->{$_id}; $_buf = $_MCE->{freeze}([ $_Q->_heap() ]); print {$_DAU_R_SOCK} length($_buf).$LF, $_buf; return; }, ); ## ------------------------------------------------------------------------- sub _mce_m_loop_begin { ($_MCE, $_DAU_R_SOCK_REF) = @_; return; } sub _mce_m_loop_end { $_MCE = $_DAU_R_SOCK_REF = $_DAU_R_SOCK = $_cnt = $_i = $_id = $_len = $_p = $_Q = undef; return; } sub _mce_m_init { MCE::_attach_plugin( \%_output_function, \&_mce_m_loop_begin, \&_mce_m_loop_end, \&_mce_w_init ); no strict 'refs'; no warnings 'redefine'; *{ 'MCE::Queue::await' } = \&_mce_m_await; *{ 'MCE::Queue::clear' } = \&_mce_m_clear; *{ 'MCE::Queue::enqueue' } = \&_mce_m_enqueue; *{ 'MCE::Queue::enqueuep' } = \&_mce_m_enqueuep; *{ 'MCE::Queue::dequeue' } = \&_mce_m_dequeue; *{ 'MCE::Queue::dequeue_nb' } = \&_mce_m_dequeue_nb; *{ 'MCE::Queue::insert' } = \&_mce_m_insert; *{ 'MCE::Queue::insertp' } = \&_mce_m_insertp; *{ 'MCE::Queue::pending' } = \&_pending; *{ 'MCE::Queue::peek' } = \&_peek; *{ 'MCE::Queue::peekp' } = \&_peekp; *{ 'MCE::Queue::peekh' } = \&_peekh; *{ 'MCE::Queue::heap' } = \&_heap; return; } } ############################################################################### ## ---------------------------------------------------------------------------- ## Wrapper methods for the manager process. ## ############################################################################### sub _mce_m_await { _croak('Queue: (await method) is not allowed by the manager process'); } sub _mce_m_clear { my $_next; my ($_Q) = @_; if ($_Q->{_fast}) { warn "Queue: (clear) is not allowed for fast => 1\n"; } else { if ($_Q->_has_data()) { sysread $_Q->{_qr_sock}, $_next, 1 } $_Q->_clear(); } return; } sub _mce_m_enqueue { my $_Q = shift; return unless (scalar @_); if (!$_Q->{_nb_flag} && !$_Q->_has_data()) { syswrite $_Q->{_qw_sock}, $LF; } push @{ $_Q->{_datq} }, @_; return; } sub _mce_m_enqueuep { my ($_Q, $_p) = (shift, shift); _croak('Queue: (enqueuep priority) is not an integer') if (!looks_like_number($_p) || int($_p) != $_p); return unless (scalar @_); if (!$_Q->{_nb_flag} && !$_Q->_has_data()) { syswrite $_Q->{_qw_sock}, $LF; } $_Q->_enqueuep($_p, @_); return; } ## ---------------------------------------------------------------------------- sub _mce_m_dequeue { my ($_Q, $_cnt) = @_; my (@_items, $_buf, $_next, $_pending); sysread $_Q->{_qr_sock}, $_next, 1; # block if (defined $_cnt && $_cnt ne '1') { @_items = $_Q->_dequeue($_cnt); } else { $_buf = $_Q->_dequeue(); } if ($_Q->{_fast}) { ## The 'fast' option may reduce wait time, thus run faster if ($_Q->{_dsem} <= 1) { $_pending = $_Q->_pending(); $_pending = int($_pending / $_cnt) if (defined $_cnt); if ($_pending) { $_pending = MAX_DQ_DEPTH if ($_pending > MAX_DQ_DEPTH); for (1 .. $_pending) { syswrite $_Q->{_qw_sock}, $LF } } $_Q->{_dsem} = $_pending; } else { $_Q->{_dsem} -= 1; } } else { ## Otherwise, never to exceed one byte in the channel if ($_Q->_has_data()) { syswrite $_Q->{_qw_sock}, $LF } } $_Q->{_nb_flag} = 0; return @_items if (defined $_cnt && $_cnt ne '1'); return $_buf; } sub _mce_m_dequeue_nb { my ($_Q, $_cnt) = @_; if ($_Q->{_fast}) { warn "Queue: (dequeue_nb) is not allowed for fast => 1\n"; return; } else { $_Q->{_nb_flag} = 1; return (defined $_cnt && $_cnt ne '1') ? $_Q->_dequeue($_cnt) : $_Q->_dequeue(); } } ## ---------------------------------------------------------------------------- sub _mce_m_insert { my ($_Q, $_i) = (shift, shift); _croak('Queue: (insert index) is not an integer') if (!looks_like_number($_i) || int($_i) != $_i); return unless (scalar @_); if (!$_Q->{_nb_flag} && !$_Q->_has_data()) { syswrite $_Q->{_qw_sock}, $LF; } $_Q->_insert($_i, @_); return; } sub _mce_m_insertp { my ($_Q, $_p, $_i) = (shift, shift, shift); _croak('Queue: (insertp priority) is not an integer') if (!looks_like_number($_p) || int($_p) != $_p); _croak('Queue: (insertp index) is not an integer') if (!looks_like_number($_i) || int($_i) != $_i); return unless (scalar @_); if (!$_Q->{_nb_flag} && !$_Q->_has_data()) { syswrite $_Q->{_qw_sock}, $LF; } $_Q->_insertp($_p, $_i, @_); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Wrapper methods for the worker process. ## ############################################################################### { my ( $_MCE, $_DAT_LOCK, $_DAT_W_SOCK, $_DAU_W_SOCK, $_chn, $_lock_chn, $_dat_ex, $_dat_un, $_len, $_next, $_pending, $_tag ); my $_is_MSWin32 = ($^O eq 'MSWin32') ? 1 : 0; my $_rdy = \&MCE::Util::_sock_ready; my $_req1 = sub { local $\ = undef if (defined $\); $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} $_[0].$LF . $_chn.$LF; print {$_DAU_W_SOCK} $_[1], $_[2]; $_dat_un->() if $_lock_chn; 1; }; my $_req2 = sub { local $\ = undef if (defined $\); local $/ = $LF if (!$/ || $/ ne $LF); $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} $_[0].$LF . $_chn.$LF; print {$_DAU_W_SOCK} $_[1]; chomp($_len = <$_DAU_W_SOCK>); if ($_len < 0) { $_dat_un->() if $_lock_chn; return undef; # Do not change to return; } read $_DAU_W_SOCK, my($_buf), $_len; $_dat_un->() if $_lock_chn; if ($_[2] == 1) { return (chop $_buf) ? $_MCE->{thaw}($_buf) : $_buf; } else { return @{ $_MCE->{thaw}($_buf) }; } }; sub _mce_w_init { ($_MCE) = @_; $_chn = $_MCE->{_chn}; $_DAT_LOCK = $_MCE->{_dat_lock}; $_DAT_W_SOCK = $_MCE->{_dat_w_sock}->[0]; $_DAU_W_SOCK = $_MCE->{_dat_w_sock}->[$_chn]; $_lock_chn = $_MCE->{_lock_chn}; if ($_lock_chn) { $_dat_ex = sub { sysread ( $_DAT_LOCK->{_r_sock}, my $_b, 1 ) }; $_dat_un = sub { syswrite ( $_DAT_LOCK->{_w_sock}, '0' ) }; } $_all = {}; no strict 'refs'; no warnings 'redefine'; *{ 'MCE::Queue::await' } = \&_mce_w_await; *{ 'MCE::Queue::clear' } = \&_mce_w_clear; *{ 'MCE::Queue::enqueue' } = \&_mce_w_enqueue; *{ 'MCE::Queue::enqueuep' } = \&_mce_w_enqueuep; *{ 'MCE::Queue::dequeue' } = \&_mce_w_dequeue; *{ 'MCE::Queue::dequeue_nb' } = \&_mce_w_dequeue_nb; *{ 'MCE::Queue::pending' } = \&_mce_w_pending; *{ 'MCE::Queue::insert' } = \&_mce_w_insert; *{ 'MCE::Queue::insertp' } = \&_mce_w_insertp; *{ 'MCE::Queue::peek' } = \&_mce_w_peek; *{ 'MCE::Queue::peekp' } = \&_mce_w_peekp; *{ 'MCE::Queue::peekh' } = \&_mce_w_peekh; *{ 'MCE::Queue::heap' } = \&_mce_w_heap; return; } ## ------------------------------------------------------------------------- sub _mce_w_await { my $_Q = shift; my $_t = shift || 0; return $_Q->_mce_m_await() if (exists $_all->{ $_Q->{_id} }); _croak('Queue: (await) is not enabled for this queue') unless ($_Q->{_await}); _croak('Queue: (await threshold) is not an integer') if (!looks_like_number($_t) || int($_t) != $_t); $_t = 0 if ($_t < 0); local $\ = undef if (defined $\); $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} OUTPUT_W_QUE.$LF . $_chn.$LF; print {$_DAU_W_SOCK} $_Q->{_id}.$LF . $_t.$LF; <$_DAU_W_SOCK>; $_dat_un->() if $_lock_chn; $_rdy->($_Q->{_ar_sock}) if $_is_MSWin32; sysread $_Q->{_ar_sock}, $_next, 1; # block return; } sub _mce_w_clear { my ($_Q) = @_; return $_Q->_mce_m_clear() if (exists $_all->{ $_Q->{_id} }); if ($_Q->{_fast}) { warn "Queue: (clear) is not allowed for fast => 1\n"; } else { local $\ = undef if (defined $\); local $/ = $LF if (!$/ || $/ ne $LF); $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} OUTPUT_C_QUE.$LF . $_chn.$LF; print {$_DAU_W_SOCK} $_Q->{_id}.$LF; <$_DAU_W_SOCK>; $_dat_un->() if $_lock_chn; } return; } ## ------------------------------------------------------------------------- sub _mce_w_enqueue { my ($_buf, $_tmp); my $_Q = shift; return $_Q->_mce_m_enqueue(@_) if (exists $_all->{ $_Q->{_id} }); return unless (scalar @_); if (@_ > 1 || ref($_[0])) { my $_tmp = $_MCE->{freeze}([ @_ ]); my $_buf = $_Q->{_id}.$LF . length($_tmp).$LF; $_req1->(OUTPUT_A_QUE, $_buf, $_tmp); } elsif (defined $_[0]) { my $_buf = $_Q->{_id}.$LF . length($_[0]).$LF; $_req1->(OUTPUT_S_QUE, $_buf, $_[0]); } elsif (scalar @_) { my $_tmp = $_MCE->{freeze}([ @_ ]); my $_buf = $_Q->{_id}.$LF . length($_tmp).$LF; $_req1->(OUTPUT_A_QUE, $_buf, $_tmp); } return; } sub _mce_w_enqueuep { my ($_buf, $_tmp); my ($_Q, $_p) = (shift, shift); _croak('Queue: (enqueuep priority) is not an integer') if (!looks_like_number($_p) || int($_p) != $_p); return $_Q->_mce_m_enqueuep($_p, @_) if (exists $_all->{ $_Q->{_id} }); return unless (scalar @_); if (@_ > 1 || ref($_[0])) { my $_tmp = $_MCE->{freeze}([ @_ ]); my $_buf = $_Q->{_id}.$LF . $_p.$LF . length($_tmp).$LF; $_req1->(OUTPUT_A_QUP, $_buf, $_tmp); } elsif (defined $_[0]) { my $_buf = $_Q->{_id}.$LF . $_p.$LF . length($_[0]).$LF; $_req1->(OUTPUT_S_QUP, $_buf, $_[0]); } elsif (scalar @_) { my $_tmp = $_MCE->{freeze}([ @_ ]); my $_buf = $_Q->{_id}.$LF . $_p.$LF . length($_tmp).$LF; $_req1->(OUTPUT_A_QUP, $_buf, $_tmp); } return; } ## ------------------------------------------------------------------------- sub _mce_w_dequeue { my $_buf; my ($_Q, $_cnt) = @_; return $_Q->_mce_m_dequeue($_cnt) if (exists $_all->{ $_Q->{_id} }); if (defined $_cnt && $_cnt ne '1') { _croak('Queue: (dequeue count argument) is not valid') if (!looks_like_number($_cnt) || int($_cnt) != $_cnt || $_cnt < 1); } else { $_cnt = 1; } $_rdy->($_Q->{_qr_sock}) if $_is_MSWin32; sysread $_Q->{_qr_sock}, $_next, 1; # block $_req2->(OUTPUT_D_QUE, $_Q->{_id}.$LF . $_cnt.$LF, $_cnt); } sub _mce_w_dequeue_nb { my $_buf; my ($_Q, $_cnt) = @_; return $_Q->_mce_m_dequeue_nb($_cnt) if (exists $_all->{ $_Q->{_id} }); if ($_Q->{_fast}) { warn "Queue: (dequeue_nb) is not allowed for fast => 1\n"; return; } if (defined $_cnt && $_cnt ne '1') { _croak('Queue: (dequeue count argument) is not valid') if (!looks_like_number($_cnt) || int($_cnt) != $_cnt || $_cnt < 1); } else { $_cnt = 1; } $_req2->(OUTPUT_D_QUN, $_Q->{_id}.$LF . $_cnt.$LF, $_cnt); } ## ------------------------------------------------------------------------- sub _mce_w_pending { my ($_Q) = @_; return $_Q->_pending() if (exists $_all->{ $_Q->{_id} }); local $\ = undef if (defined $\); local $/ = $LF if (!$/ || $/ ne $LF); $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} OUTPUT_N_QUE.$LF . $_chn.$LF; print {$_DAU_W_SOCK} $_Q->{_id}.$LF; chomp($_pending = <$_DAU_W_SOCK>); $_dat_un->() if $_lock_chn; return $_pending; } sub _mce_w_insert { my ($_buf, $_tmp); my ($_Q, $_i) = (shift, shift); _croak('Queue: (insert index) is not an integer') if (!looks_like_number($_i) || int($_i) != $_i); return $_Q->_mce_m_insert($_i, @_) if (exists $_all->{ $_Q->{_id} }); return unless (scalar @_); if (scalar @_ > 1 || ref $_[0] || !defined $_[0]) { $_tmp = $_MCE->{freeze}([ @_ ]); $_buf = $_Q->{_id}.$LF . $_i.$LF . (length($_tmp) + 1).$LF . $_tmp.'1'; } else { $_buf = $_Q->{_id}.$LF . $_i.$LF . (length($_[0]) + 1).$LF . $_[0].'0'; } $_req1->(OUTPUT_I_QUE, $_buf, ''); return; } sub _mce_w_insertp { my ($_buf, $_tmp); my ($_Q, $_p, $_i) = (shift, shift, shift); _croak('Queue: (insertp priority) is not an integer') if (!looks_like_number($_p) || int($_p) != $_p); _croak('Queue: (insertp index) is not an integer') if (!looks_like_number($_i) || int($_i) != $_i); return $_Q->_mce_m_insertp($_p, $_i, @_) if (exists $_all->{ $_Q->{_id} }); return unless (scalar @_); if (scalar @_ > 1 || ref $_[0] || !defined $_[0]) { $_tmp = $_MCE->{freeze}([ @_ ]); $_buf = $_Q->{_id}.$LF . $_p.$LF . $_i.$LF . (length($_tmp) + 1).$LF . $_tmp.'1'; } else { $_buf = $_Q->{_id}.$LF . $_p.$LF . $_i.$LF . (length($_[0]) + 1).$LF . $_[0].'0'; } $_req1->(OUTPUT_I_QUP, $_buf, ''); return; } ## ------------------------------------------------------------------------- sub _mce_w_peek { my $_buf; my $_Q = shift; my $_i = shift || 0; _croak('Queue: (peek index) is not an integer') if (!looks_like_number($_i) || int($_i) != $_i); return $_Q->_peek($_i, @_) if (exists $_all->{ $_Q->{_id} }); { local $\ = undef if (defined $\); local $/ = $LF if (!$/ || $/ ne $LF); $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} OUTPUT_P_QUE.$LF . $_chn.$LF; print {$_DAU_W_SOCK} $_Q->{_id}.$LF . $_i.$LF; chomp($_len = <$_DAU_W_SOCK>); if ($_len < 0) { $_dat_un->() if $_lock_chn; return undef; # Do not change to return; } read $_DAU_W_SOCK, $_buf, $_len; $_dat_un->() if $_lock_chn; } return (chop $_buf) ? $_MCE->{thaw}($_buf) : $_buf; } sub _mce_w_peekp { my $_buf; my ($_Q, $_p) = (shift, shift); my $_i = shift || 0; _croak('Queue: (peekp priority) is not an integer') if (!looks_like_number($_p) || int($_p) != $_p); _croak('Queue: (peekp index) is not an integer') if (!looks_like_number($_i) || int($_i) != $_i); return $_Q->_peekp($_p, $_i, @_) if (exists $_all->{ $_Q->{_id} }); { local $\ = undef if (defined $\); local $/ = $LF if (!$/ || $/ ne $LF); $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} OUTPUT_P_QUP.$LF . $_chn.$LF; print {$_DAU_W_SOCK} $_Q->{_id}.$LF . $_p.$LF . $_i.$LF; chomp($_len = <$_DAU_W_SOCK>); if ($_len < 0) { $_dat_un->() if $_lock_chn; return undef; # Do not change to return; } read $_DAU_W_SOCK, $_buf, $_len; $_dat_un->() if $_lock_chn; } return (chop $_buf) ? $_MCE->{thaw}($_buf) : $_buf; } sub _mce_w_peekh { my $_buf; my $_Q = shift; my $_i = shift || 0; _croak('Queue: (peekh index) is not an integer') if (!looks_like_number($_i) || int($_i) != $_i); return $_Q->_peekh($_i, @_) if (exists $_all->{ $_Q->{_id} }); { local $\ = undef if (defined $\); local $/ = $LF if (!$/ || $/ ne $LF); $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} OUTPUT_P_QUH.$LF . $_chn.$LF; print {$_DAU_W_SOCK} $_Q->{_id}.$LF . $_i.$LF; chomp($_len = <$_DAU_W_SOCK>); if ($_len < 0) { $_dat_un->() if $_lock_chn; return undef; # Do not change to return; } read $_DAU_W_SOCK, $_buf, $_len; $_dat_un->() if $_lock_chn; } return $_buf; } ## ------------------------------------------------------------------------- sub _mce_w_heap { my $_buf; my ($_Q) = @_; return $_Q->_heap() if (exists $_all->{ $_Q->{_id} }); { local $\ = undef if (defined $\); local $/ = $LF if (!$/ || $/ ne $LF); $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} OUTPUT_H_QUE.$LF . $_chn.$LF; print {$_DAU_W_SOCK} $_Q->{_id}.$LF; chomp($_len = <$_DAU_W_SOCK>); read $_DAU_W_SOCK, $_buf, $_len; $_dat_un->() if $_lock_chn; } return @{ $_MCE->{thaw}($_buf) }; } } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Queue - Hybrid (normal and priority) queues =head1 VERSION This document describes MCE::Queue version 1.810 =head1 SYNOPSIS use MCE; use MCE::Queue; my $q = MCE::Queue->new; $q->enqueue( qw/ wherefore art thou romeo / ); my $item = $q->dequeue; if ( $q->pending ) { ; } =head1 DESCRIPTION This module provides a queue interface supporting normal and priority queues and utilizing the IPC engine behind MCE. Data resides under the manager process. MCE::Queue also allows for a worker to create any number of queues locally not available to other workers including the manager process. Think of a CPU having L3 (shared) and L1 (local) cache. Three options are available for overriding the default value for new queues. The porder option applies to priority queues only. use MCE::Queue porder => $MCE::Queue::HIGHEST, type => $MCE::Queue::FIFO, fast => 0; use MCE::Queue; # Same as above ## Possible values porder => $MCE::Queue::HIGHEST # Highest priority items dequeue first $MCE::Queue::LOWEST # Lowest priority items dequeue first type => $MCE::Queue::FIFO # First in, first out $MCE::Queue::LIFO # Last in, first out $MCE::Queue::LILO # (Synonym for FIFO) $MCE::Queue::FILO # (Synonym for LIFO) =head1 THREE RUN MODES MCE::Queue can be utilized under the following conditions: (A) use MCE; (B) use MCE::Queue; (C) use MCE::Queue; use MCE::Queue; use MCE; =over 3 =item (A) MCE is included prior to inclusion of MCE::Queue The dequeue method blocks for the manager process including workers. All data resides under the manager process. Workers send/request data via IPC. Creating a queue from within the worker process will cause the queue to run in local mode (C). The data resides under the worker process and not available to other workers including the manager process. =item (B) MCE::Queue is included prior to inclusion of MCE Queues behave as if running in local mode for the manager and worker processes for the duration of the script. I cannot think of a use-case for this, but mentioning the behavior in the event MCE::Queue is included before MCE. =item (C) MCE::Queue without inclusion of MCE The dequeue method is non-blocking. Queues behave similarly to local queuing. This mode is efficient due to minimum overhead and zero IPC behind the scene. Hence, MCE is not required to use MCE::Queue. =back =head1 DEMONSTRATION use MCE; use MCE::Queue; my $F = MCE::Queue->new(fast => 1); my $consumers = 8; my $mce = MCE->new( task_end => sub { my ($mce, $task_id, $task_name) = @_; $F->enqueue((undef) x $consumers) if $task_name eq 'dir'; }, user_tasks => [{ max_workers => 1, task_name => 'dir', user_func => sub { ## Create a "standalone queue" only accessible to this worker. ## See included examples for running with multiple workers. my $D = MCE::Queue->new(queue => [ MCE->user_args->[0] ]); while (defined (my $dir = $D->dequeue_nb)) { my (@files, @dirs); foreach (glob("$dir/*")) { if (-d $_) { push @dirs, $_; next; } push @files, $_; } $D->enqueue(@dirs ) if scalar @dirs; $F->enqueue(@files) if scalar @files; } } },{ max_workers => $consumers, task_name => 'file', user_func => sub { while (defined (my $file = $F->dequeue)) { MCE->say($file); } } }] )->run({ user_args => [ $ARGV[0] || '.' ] }); __END__ Results from files_mce.pl and files_thr.pl; included with MCE. Usage: time ./files_mce.pl /usr 0 | wc -l time ./files_mce.pl /usr 1 | wc -l time ./files_thr.pl /usr | wc -l Darwin (OS) /usr: 216,271 files MCE::Queue, fast => 0 : 4.17s MCE::Queue, fast => 1 : 2.62s Thread::Queue : 4.14s Linux (VM) /usr: 186,154 files MCE::Queue, fast => 0 : 12.57s MCE::Queue, fast => 1 : 3.36s Thread::Queue : 5.91s Solaris (VM) /usr: 603,051 files MCE::Queue, fast => 0 : 39.04s MCE::Queue, fast => 1 : 18.08s Thread::Queue * Perl not built to support threads =head1 API DOCUMENTATION =head2 MCE::Queue->new ( [ queue => \@array, await => 1, fast => 1 ] ) This creates a new queue. Available options are queue, porder, type, await, fast, and gather. use MCE; use MCE::Queue; my $q1 = MCE::Queue->new(); my $q2 = MCE::Queue->new( queue => [ 0, 1, 2 ] ); my $q3 = MCE::Queue->new( porder => $MCE::Queue::HIGHEST ); my $q4 = MCE::Queue->new( porder => $MCE::Queue::LOWEST ); my $q5 = MCE::Queue->new( type => $MCE::Queue::FIFO ); my $q6 = MCE::Queue->new( type => $MCE::Queue::LIFO ); my $q7 = MCE::Queue->new( await => 1 ); my $q8 = MCE::Queue->new( fast => 1 ); The 'await' option, when enabled, allows workers to block (semaphore-like) until the number of items pending is equal or less than a threshold value. The $q->await method is described below. The 'fast' option speeds up dequeues and is not enabled by default. It is beneficial for queues not calling (->clear or ->dequeue_nb) and not altering the optional count value while running; e.g. ->dequeue($count). Basically, do not enable 'fast' if varying the count dynamically. The 'gather' option is mainly for running with MCE and wanting to pass item(s) to a callback function for appending to the queue. Multiple queues may point to the same callback function. The callback receives the queue object as the first argument and items after it. sub _append { my ($q, @items) = @_; $q->enqueue(@items); } my $q7 = MCE::Queue->new( gather => \&_append ); my $q8 = MCE::Queue->new( gather => \&_append ); ## Items are diverted to the callback function, not the queue. $q7->enqueue( 'apple', 'orange' ); Specifying the 'gather' option allows one to store items temporarily while ensuring output order. Although a queue object is not required, this is simply a demonstration of the gather option in the context of a queue. use MCE; use MCE::Queue; sub preserve_order { my %tmp; my $order_id = 1; return sub { my ($q, $chunk_id, $data) = @_; $tmp{$chunk_id} = $data; while (1) { last unless exists $tmp{$order_id}; $q->enqueue( delete $tmp{$order_id++} ); } return; }; } my @squares; my $q = MCE::Queue->new( queue => \@squares, gather => preserve_order ); my $mce = MCE->new( chunk_size => 1, input_data => [ 1 .. 100 ], user_func => sub { $q->enqueue( MCE->chunk_id, $_ * $_ ); } ); $mce->run; print "@squares\n"; =head2 $q->await ( $pending_threshold ) The await method is beneficial when wanting to throttle worker(s) appending to the queue. Perhaps, consumers are running a bit behind and wanting to keep tabs on memory consumption. Below, the number of items pending will never go above 20. use Time::HiRes qw( sleep ); use MCE::Flow; use MCE::Queue; my $q = MCE::Queue->new( await => 1, fast => 1 ); my ( $producers, $consumers ) = ( 1, 8 ); mce_flow { task_name => [ 'producer', 'consumer' ], max_workers => [ $producers, $consumers ], }, sub { ## producer for my $item ( 1 .. 100 ) { $q->enqueue($item); ## blocks until the # of items pending reaches <= 10 if ($item % 10 == 0) { MCE->say( 'pending: '.$q->pending() ); $q->await(10); } } ## notify consumers no more work $q->enqueue( (undef) x $consumers ); }, sub { ## consumers while (defined (my $next = $q->dequeue())) { MCE->say( MCE->task_wid().': '.$next ); sleep 0.100; } }; =head2 $q->clear ( void ) Clears the queue of any items. This has the effect of nulling the queue and the socket used for blocking. my @a; my $q = MCE::Queue->new( queue => \@a ); @a = (); ## bad, the blocking socket may become out of sync $q->clear; ## ok =head2 $q->enqueue ( $item [, $item, ... ] ) Appends a list of items onto the end of the normal queue. $q->enqueue( 'foo' ); $q->enqueue( 'bar', 'baz' ); =head2 $q->enqueuep ( $p, $item [, $item, ... ] ) Appends a list of items onto the end of the priority queue with priority. $q->enqueue( $priority, 'foo' ); $q->enqueue( $priority, 'bar', 'baz' ); =head2 $q->dequeue ( [ $count ] ) Returns the requested number of items (default 1) from the queue. Priority data will always dequeue first before any data from the normal queue. $q->dequeue( 2 ); $q->dequeue; # default 1 The method will block if the queue contains zero items. If the queue contains fewer than the requested number of items, the method will not block, but return the remaining items and C for up to the count requested. The $count, used for requesting the number of items, is beneficial when workers are passing parameters through the queue. For this reason, always remember to dequeue using the same multiple for the count. This is unlike Thread::Queue which will block until the requested number of items are available. =head2 $q->dequeue_nb ( [ $count ] ) Returns the requested number of items (default 1) from the queue. Like with dequeue, priority data will always dequeue first. This method is non-blocking and will return C in the absence of data from the queue. $q->dequeue_nb( 2 ); $q->dequeue_nb; # default 1 =head2 $q->insert ( $index, $item [, $item, ... ] ) Adds the list of items to the queue at the specified index position (0 is the head of the list). The head of the queue is that item which would be removed by a call to dequeue. $q = MCE::Queue->new( type => $MCE::Queue::FIFO ); $q->enqueue(1, 2, 3, 4); $q->insert(1, 'foo', 'bar'); # Queue now contains: 1, foo, bar, 2, 3, 4 $q = MCE::Queue->new( type => $MCE::Queue::LIFO ); $q->enqueue(1, 2, 3, 4); $q->insert(1, 'foo', 'bar'); # Queue now contains: 1, 2, 3, 'foo', 'bar', 4 =head2 $q->insertp ( $p, $index, $item [, $item, ... ] ) Adds the list of items to the queue at the specified index position with priority. The behavior is similarly to C<$q->insert> otherwise. =head2 $q->pending ( void ) Returns the number of items in the queue. The count includes both normal and priority data. $q = MCE::Queue->new(); $q->enqueuep(5, 'foo', 'bar'); $q->enqueue('sunny', 'day'); print $q->pending(), "\n"; # Output: 4 =head2 $q->peek ( [ $index ] ) Returns an item from the normal queue, at the specified index, without dequeuing anything. It defaults to the head of the queue if index is not specified. The head of the queue is that item which would be removed by a call to dequeue. Negative index values are supported, similarly to arrays. $q = MCE::Queue->new( type => $MCE::Queue::FIFO ); $q->enqueue(1, 2, 3, 4, 5); print $q->peek(1), ' ', $q->peek(-2), "\n"; # Output: 2 4 $q = MCE::Queue->new( type => $MCE::Queue::LIFO ); $q->enqueue(1, 2, 3, 4, 5); print $q->peek(1), ' ', $q->peek(-2), "\n"; # Output: 4 2 =head2 $q->peekp ( $p [, $index ] ) Returns an item from the queue with priority, at the specified index, without dequeuing anything. It defaults to the head of the queue if index is not specified. The behavior is similarly to C<$q->peek> otherwise. =head2 $q->peekh ( [ $index ] ) Returns an item from the head of the heap or at the specified index. $q = MCE::Queue->new( porder => $MCE::Queue::HIGHEST ); $q->enqueuep(5, 'foo'); $q->enqueuep(6, 'bar'); $q->enqueuep(4, 'sun'); print $q->peekh(0), "\n"; # Output: 6 $q = MCE::Queue->new( porder => $MCE::Queue::LOWEST ); $q->enqueuep(5, 'foo'); $q->enqueuep(6, 'bar'); $q->enqueuep(4, 'sun'); print $q->peekh(0), "\n"; # Output: 4 =head2 $q->heap ( void ) Returns an array containing the heap data. Heap data consists of priority numbers, not the data. @h = $q->heap; # $MCE::Queue::HIGHEST # Heap contains: 6, 5, 4 @h = $q->heap; # $MCE::Queue::LOWEST # Heap contains: 4, 5, 6 =head1 ACKNOWLEDGMENTS =over 3 =item L The bsearch_num_pos method was helpful for accommodating the highest and lowest order in MCE::Queue. =item L For extra optimization, two if statements were adopted for checking if the item belongs at the end or head of the queue. =item L MCE::Queue supports both normal and priority queues. =item L Thread::Queue is used as a template for identifying and documenting the methods. MCE::Queue is not fully compatible due to supporting normal and priority queues simultaneously; e.g. $q->enqueue( $item [, $item, ... ] ); # normal queue $q->enqueuep( $p, $item [, $item, ... ] ); # priority queue $q->dequeue( [ $count ] ); # priority data dequeues first $q->dequeue_nb( [ $count ] ); $q->pending(); # counts both normal/priority queues =item L The recursion example, in the synopsis above, was largely adopted from this module. =back =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.810/lib/MCE/Mutex.pm0000644000175000017500000001034713022712406013743 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## Locking for Many-Core Engine. ## ############################################################################### package MCE::Mutex; use strict; use warnings; no warnings qw( threads recursion uninitialized ); our $VERSION = '1.810'; use MCE::Util qw( $LF ); my $_has_threads = $INC{'threads.pm'} ? 1 : 0; my $_tid = $_has_threads ? threads->tid() : 0; sub CLONE { $_tid = threads->tid() if $_has_threads; } sub DESTROY { my ($_obj, $_arg) = @_; my $_pid = $_has_threads ? $$ .'.'. $_tid : $$; $_obj->unlock() if ($_obj->{ $_pid }); if ($_arg eq 'shutdown' || $_obj->{'init_pid'} eq $_pid) { ($^O eq 'MSWin32') ? MCE::Util::_destroy_pipes($_obj, qw(_w_sock _r_sock)) : MCE::Util::_destroy_socks($_obj, qw(_w_sock _r_sock)); } return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Public methods. ## ############################################################################### sub new { my ($_class, %_obj) = @_; $_obj{'init_pid'} = $_has_threads ? $$ .'.'. $_tid : $$; ($^O eq 'MSWin32') ? MCE::Util::_pipe_pair(\%_obj, qw(_r_sock _w_sock)) : MCE::Util::_sock_pair(\%_obj, qw(_r_sock _w_sock)); syswrite($_obj{_w_sock}, '0'); return bless(\%_obj, $_class); } sub lock { my ($_pid, $_obj) = ($_has_threads ? $$ .'.'. $_tid : $$, @_); sysread($_obj->{_r_sock}, my($_b), 1), $_obj->{ $_pid } = 1 unless $_obj->{ $_pid }; return; } sub unlock { my ($_pid, $_obj) = ($_has_threads ? $$ .'.'. $_tid : $$, @_); syswrite($_obj->{_w_sock}, '0'), $_obj->{ $_pid } = 0 if $_obj->{ $_pid }; return; } sub synchronize { my ($_obj, $_code) = (shift, shift); return if (ref $_code ne 'CODE'); if (defined wantarray) { $_obj->lock(); my @_a = $_code->(@_); $_obj->unlock(); return wantarray ? @_a : $_a[0]; } else { $_obj->lock(); $_code->(@_); $_obj->unlock(); } return; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Mutex - Locking for Many-Core Engine =head1 VERSION This document describes MCE::Mutex version 1.810 =head1 SYNOPSIS use MCE::Flow max_workers => 4; use MCE::Mutex; print "## running a\n"; my $a = MCE::Mutex->new; mce_flow sub { $a->lock; ## access shared resource my $wid = MCE->wid; MCE->say($wid); sleep 1; $a->unlock; }; print "## running b\n"; my $b = MCE::Mutex->new; mce_flow sub { $b->synchronize( sub { ## access shared resource my ($wid) = @_; MCE->say($wid); sleep 1; }, MCE->wid ); }; =head1 DESCRIPTION This module implements locking methods that can be used to coordinate access to shared data from multiple workers spawned as processes or threads. The inspiration for this module came from reading Mutex for Ruby. =head1 API DOCUMENTATION =head2 MCE::Mutex->new ( void ) Creates a new mutex. Channel locking is through a pipe or socket depending on platform. The advantage of channel locking is not having to re-establish handles inside new processes or threads. =head2 $m->lock ( void ) Attempts to grab the lock and waits if not available. Multiple calls to mutex->lock by the same process or thread is safe. The mutex will remain locked until mutex->unlock is called. =head2 $m->unlock ( void ) Releases the lock. A held lock by an exiting process or thread is released automatically. =head2 $m->synchronize ( sub { ... }, @_ ) Obtains a lock, runs the code block, and releases the lock after the block completes. Optionally, the method is C aware. my $value = $m->synchronize( sub { ## access shared resource 'value'; }); =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.810/lib/MCE/Loop.pm0000644000175000017500000005651413022712402013554 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## Parallel loop model for building creative loops. ## ############################################################################### package MCE::Loop; use strict; use warnings; no warnings qw( threads recursion uninitialized ); our $VERSION = '1.810'; ## no critic (BuiltinFunctions::ProhibitStringyEval) ## no critic (Subroutines::ProhibitSubroutinePrototypes) ## no critic (TestingAndDebugging::ProhibitNoStrict) use Scalar::Util qw( looks_like_number ); use MCE; our @CARP_NOT = qw( MCE ); my $_has_threads = $INC{'threads.pm'} ? 1 : 0; my $_tid = $_has_threads ? threads->tid() : 0; sub CLONE { $_tid = threads->tid() if $_has_threads; } ############################################################################### ## ---------------------------------------------------------------------------- ## Import routine. ## ############################################################################### my ($_MCE, $_def, $_params, $_prev_c, $_tag) = ({}, {}, {}, {}, 'MCE::Loop'); sub import { my ($_class, $_pkg) = (shift, caller); my $_p = $_def->{$_pkg} = { MAX_WORKERS => 'auto', CHUNK_SIZE => 'auto', }; ## Import functions. no strict 'refs'; no warnings 'redefine'; *{ $_pkg.'::mce_loop_f' } = \&run_file; *{ $_pkg.'::mce_loop_s' } = \&run_seq; *{ $_pkg.'::mce_loop' } = \&run; ## Process module arguments. while ( my $_argument = shift ) { my $_arg = lc $_argument; $_p->{MAX_WORKERS} = shift, next if ( $_arg eq 'max_workers' ); $_p->{CHUNK_SIZE} = shift, next if ( $_arg eq 'chunk_size' ); $_p->{TMP_DIR} = shift, next if ( $_arg eq 'tmp_dir' ); $_p->{FREEZE} = shift, next if ( $_arg eq 'freeze' ); $_p->{THAW} = shift, next if ( $_arg eq 'thaw' ); ## Sereal 3.008+, if available, is used automatically by MCE 1.800. if ( $_arg eq 'sereal' ) { if ( shift eq '0' ) { require Storable; $_p->{FREEZE} = \&Storable::freeze; $_p->{THAW} = \&Storable::thaw; } next; } _croak("Error: ($_argument) invalid module option"); } $_p->{MAX_WORKERS} = MCE::Util::_parse_max_workers($_p->{MAX_WORKERS}); _validate_number($_p->{MAX_WORKERS}, 'MAX_WORKERS'); _validate_number($_p->{CHUNK_SIZE}, 'CHUNK_SIZE') unless ($_p->{CHUNK_SIZE} eq 'auto'); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Init and finish routines. ## ############################################################################### sub init (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Loop'); my $_pkg = "$$.$_tid.".caller(); $_params->{$_pkg} = (ref $_[0] eq 'HASH') ? shift : { @_ }; @_ = (); return; } sub finish (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Loop'); my $_pkg = (defined $_[0]) ? shift : "$$.$_tid.".caller(); if ( $_pkg eq 'MCE' ) { for my $_k ( keys %{ $_MCE } ) { MCE::Loop->finish($_k, 1); } } elsif ( $_MCE->{$_pkg} && $_MCE->{$_pkg}{_init_pid} eq "$$.$_tid" ) { $_MCE->{$_pkg}->shutdown(@_) if $_MCE->{$_pkg}{_spawned}; delete $_prev_c->{$_pkg}; delete $_MCE->{$_pkg}; } @_ = (); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Parallel loop with MCE -- file. ## ############################################################################### sub run_file (&@) { shift if (defined $_[0] && $_[0] eq 'MCE::Loop'); my $_code = shift; my $_file = shift; my $_pid = "$$.$_tid.".caller(); if (defined (my $_p = $_params->{$_pid})) { delete $_p->{input_data} if (exists $_p->{input_data}); delete $_p->{sequence} if (exists $_p->{sequence}); } else { $_params->{$_pid} = {}; } if (defined $_file && ref $_file eq '' && $_file ne '') { _croak("$_tag: ($_file) does not exist") unless (-e $_file); _croak("$_tag: ($_file) is not readable") unless (-r $_file); _croak("$_tag: ($_file) is not a plain file") unless (-f $_file); $_params->{$_pid}{_file} = $_file; } elsif (ref $_file eq 'SCALAR' || ref($_file) =~ /^(?:GLOB|FileHandle|IO::)/) { $_params->{$_pid}{_file} = $_file; } else { _croak("$_tag: (file) is not specified or valid"); } @_ = (); return run($_code); } ############################################################################### ## ---------------------------------------------------------------------------- ## Parallel loop with MCE -- sequence. ## ############################################################################### sub run_seq (&@) { shift if (defined $_[0] && $_[0] eq 'MCE::Loop'); my $_code = shift; my $_pid = "$$.$_tid.".caller(); if (defined (my $_p = $_params->{$_pid})) { delete $_p->{input_data} if (exists $_p->{input_data}); delete $_p->{_file} if (exists $_p->{_file}); } else { $_params->{$_pid} = {}; } my ($_begin, $_end); if (ref $_[0] eq 'HASH') { $_begin = $_[0]->{begin}; $_end = $_[0]->{end}; $_params->{$_pid}{sequence} = $_[0]; } elsif (ref $_[0] eq 'ARRAY') { $_begin = $_[0]->[0]; $_end = $_[0]->[1]; $_params->{$_pid}{sequence} = $_[0]; } elsif (ref $_[0] eq '') { $_begin = $_[0]; $_end = $_[1]; $_params->{$_pid}{sequence} = [ @_ ]; } else { _croak("$_tag: (sequence) is not specified or valid"); } _croak("$_tag: (begin) is not specified for sequence") unless (defined $_begin); _croak("$_tag: (end) is not specified for sequence") unless (defined $_end); $_params->{$_pid}{sequence_run} = 1; @_ = (); return run($_code); } ############################################################################### ## ---------------------------------------------------------------------------- ## Parallel loop with MCE. ## ############################################################################### sub run (&@) { shift if (defined $_[0] && $_[0] eq 'MCE::Loop'); my $_code = shift; my $_pkg = caller() eq 'MCE::Loop' ? caller(1) : caller(); my $_pid = "$$.$_tid.$_pkg"; my $_input_data; my $_max_workers = $_def->{$_pkg}{MAX_WORKERS}; my $_r = ref $_[0]; if ($_r eq 'ARRAY' || $_r eq 'CODE' || $_r eq 'SCALAR' || $_r =~ /^(?:GLOB|FileHandle|IO::)/) { $_input_data = shift if (@_ == 1); } if (defined (my $_p = $_params->{$_pid})) { $_max_workers = MCE::Util::_parse_max_workers($_p->{max_workers}) if (exists $_p->{max_workers}); delete $_p->{sequence} if (defined $_input_data || scalar @_); delete $_p->{user_func} if (exists $_p->{user_func}); delete $_p->{user_tasks} if (exists $_p->{user_tasks}); } my $_chunk_size = MCE::Util::_parse_chunk_size( $_def->{$_pkg}{CHUNK_SIZE}, $_max_workers, $_params->{$_pid}, $_input_data, scalar @_ ); if (defined (my $_p = $_params->{$_pid})) { if (exists $_p->{_file}) { $_input_data = delete $_p->{_file}; } else { $_input_data = $_p->{input_data} if exists $_p->{input_data}; } } ## ------------------------------------------------------------------------- MCE::_save_state(); if (!defined $_prev_c->{$_pid} || $_prev_c->{$_pid} != $_code) { $_MCE->{$_pid}->shutdown() if (defined $_MCE->{$_pid}); $_prev_c->{$_pid} = $_code; my %_opts = ( max_workers => $_max_workers, task_name => $_tag, user_func => $_code, ); if (defined (my $_p = $_params->{$_pid})) { for my $_k (keys %{ $_p }) { next if ($_k eq 'sequence_run'); next if ($_k eq 'input_data'); next if ($_k eq 'chunk_size'); _croak("MCE::Loop: ($_k) is not a valid constructor argument") unless (exists $MCE::_valid_fields_new{$_k}); $_opts{$_k} = $_p->{$_k}; } } for my $_k (qw/ tmp_dir freeze thaw /) { $_opts{$_k} = $_def->{$_pkg}{uc($_k)} if (exists $_def->{$_pkg}{uc($_k)} && !exists $_opts{$_k}); } $_MCE->{$_pid} = MCE->new(pkg => $_pkg, %_opts); } ## ------------------------------------------------------------------------- my @_a; my $_wa = wantarray; $_MCE->{$_pid}{gather} = \@_a if (defined $_wa); if (defined $_input_data) { @_ = (); $_MCE->{$_pid}->process({ chunk_size => $_chunk_size }, $_input_data); delete $_MCE->{$_pid}{input_data}; } elsif (scalar @_) { $_MCE->{$_pid}->process({ chunk_size => $_chunk_size }, \@_); delete $_MCE->{$_pid}{input_data}; } else { if (defined $_params->{$_pid} && exists $_params->{$_pid}{sequence}) { $_MCE->{$_pid}->run({ chunk_size => $_chunk_size, sequence => $_params->{$_pid}{sequence} }, 0); if (exists $_params->{$_pid}{sequence_run}) { delete $_params->{$_pid}{sequence_run}; delete $_params->{$_pid}{sequence}; } delete $_MCE->{$_pid}{sequence}; } } MCE::_restore_state(); delete $_MCE->{$_pid}{gather} if (defined $_wa); return ((defined $_wa) ? @_a : ()); } ############################################################################### ## ---------------------------------------------------------------------------- ## Private methods. ## ############################################################################### sub _croak { goto &MCE::_croak; } sub _validate_number { my ($_n, $_key) = @_; _croak("$_tag: ($_key) is not valid") if (!defined $_n); $_n =~ s/K\z//i; $_n =~ s/M\z//i; if (!looks_like_number($_n) || int($_n) != $_n || $_n < 1) { _croak("$_tag: ($_key) is not valid"); } return; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Loop - Parallel loop model for building creative loops =head1 VERSION This document describes MCE::Loop version 1.810 =head1 DESCRIPTION This module provides a parallel loop implementation through Many-Core Engine. MCE::Loop is not MCE::Map but more along the lines of an easy way to spin up a MCE instance and have user_func pointing to your code block. If you want something similar to map, then see L. ## Construction when chunking is not desired use MCE::Loop; MCE::Loop::init { max_workers => 5, chunk_size => 1 }; mce_loop { my ($mce, $chunk_ref, $chunk_id) = @_; MCE->say("$chunk_id: $_"); } 40 .. 48; -- Output 3: 42 1: 40 2: 41 4: 43 5: 44 6: 45 7: 46 8: 47 9: 48 ## Construction for 'auto' or greater than 1 use MCE::Loop; MCE::Loop::init { max_workers => 5, chunk_size => 'auto' }; mce_loop { my ($mce, $chunk_ref, $chunk_id) = @_; for (@{ $chunk_ref }) { MCE->say("$chunk_id: $_"); } } 40 .. 48; -- Output 1: 40 2: 42 1: 41 4: 46 2: 43 5: 48 3: 44 4: 47 3: 45 =head1 SYNOPSIS when CHUNK_SIZE EQUALS 1 All models in MCE default to 'auto' for chunk_size. The arguments for the block are the same as writing a user_func block using the Core API. Beginning with MCE 1.5, the next input item is placed into the input scalar variable $_ when chunk_size equals 1. Otherwise, $_ points to $chunk_ref containing many items. Basically, line 2 below may be omitted from your code when using $_. One can call MCE->chunk_id to obtain the current chunk id. line 1: user_func => sub { line 2: my ($mce, $chunk_ref, $chunk_id) = @_; line 3: line 4: $_ points to $chunk_ref->[0] line 5: in MCE 1.5 when chunk_size == 1 line 6: line 7: $_ points to $chunk_ref line 8: in MCE 1.5 when chunk_size > 1 line 9: } Follow this synopsis when chunk_size equals one. Looping is not required from inside the block. Hence, the block is called once per each item. ## Exports mce_loop, mce_loop_f, and mce_loop_s use MCE::Loop; MCE::Loop::init { chunk_size => 1 }; ## Array or array_ref mce_loop { do_work($_) } 1..10000; mce_loop { do_work($_) } [ 1..10000 ]; ## File_path, glob_ref, or scalar_ref mce_loop_f { chomp; do_work($_) } "/path/to/file"; mce_loop_f { chomp; do_work($_) } $file_handle; mce_loop_f { chomp; do_work($_) } \$scalar; ## Sequence of numbers (begin, end [, step, format]) mce_loop_s { do_work($_) } 1, 10000, 5; mce_loop_s { do_work($_) } [ 1, 10000, 5 ]; mce_loop_s { do_work($_) } { begin => 1, end => 10000, step => 5, format => undef }; =head1 SYNOPSIS when CHUNK_SIZE is GREATER THAN 1 Follow this synopsis when chunk_size equals 'auto' or greater than 1. This means having to loop through the chunk from inside the block. use MCE::Loop; MCE::Loop::init { ## Chunk_size defaults to 'auto' when chunk_size => 'auto' ## not specified. Therefore, the init }; ## function may be omitted. ## Syntax is shown for mce_loop for demonstration purposes. ## Looping inside the block is the same for mce_loop_f and ## mce_loop_s. mce_loop { do_work($_) for (@{ $_ }) } 1..10000; ## Same as above, resembles code using the Core API. mce_loop { my ($mce, $chunk_ref, $chunk_id) = @_; for (@{ $chunk_ref }) { do_work($_); } } 1..10000; Chunking reduces the number of IPC calls behind the scene. Think in terms of chunks whenever processing a large amount of data. For relatively small data, choosing 1 for chunk_size is fine. =head1 OVERRIDING DEFAULTS The following list options which may be overridden when loading the module. use Sereal qw( encode_sereal decode_sereal ); use CBOR::XS qw( encode_cbor decode_cbor ); use JSON::XS qw( encode_json decode_json ); use MCE::Loop max_workers => 4, # Default 'auto' chunk_size => 100, # Default 'auto' tmp_dir => "/path/to/app/tmp", # $MCE::Signal::tmp_dir freeze => \&encode_sereal, # \&Storable::freeze thaw => \&decode_sereal # \&Storable::thaw ; From MCE 1.8 onwards, Sereal 3.008+ is loaded automatically if available. Specify C 0> to use Storable instead. use MCE::Loop Sereal => 0; =head1 CUSTOMIZING MCE =over 3 =item MCE::Loop->init ( options ) =item MCE::Loop::init { options } The init function accepts a hash of MCE options. use MCE::Loop; MCE::Loop::init { chunk_size => 1, max_workers => 4, user_begin => sub { print "## ", MCE->wid, " started\n"; }, user_end => sub { print "## ", MCE->wid, " completed\n"; } }; my %a = mce_loop { MCE->gather($_, $_ * $_) } 1..100; print "\n", "@a{1..100}", "\n"; -- Output ## 3 started ## 1 started ## 2 started ## 4 started ## 1 completed ## 2 completed ## 3 completed ## 4 completed 1 4 9 16 25 36 49 64 81 100 121 144 169 196 225 256 289 324 361 400 441 484 529 576 625 676 729 784 841 900 961 1024 1089 1156 1225 1296 1369 1444 1521 1600 1681 1764 1849 1936 2025 2116 2209 2304 2401 2500 2601 2704 2809 2916 3025 3136 3249 3364 3481 3600 3721 3844 3969 4096 4225 4356 4489 4624 4761 4900 5041 5184 5329 5476 5625 5776 5929 6084 6241 6400 6561 6724 6889 7056 7225 7396 7569 7744 7921 8100 8281 8464 8649 8836 9025 9216 9409 9604 9801 10000 =back =head1 API DOCUMENTATION The following assumes chunk_size equals 1 in order to demonstrate all the possibilities of passing input data into the code block. =over 3 =item MCE::Loop->run ( sub { code }, iterator ) =item mce_loop { code } iterator An iterator reference can by specified for input_data. Iterators are described under "SYNTAX for INPUT_DATA" at L. mce_loop { $_ } make_iterator(10, 30, 2); =item MCE::Loop->run ( sub { code }, list ) =item mce_loop { code } list Input data can be defined using a list. mce_loop { $_ } 1..1000; mce_loop { $_ } [ 1..1000 ]; =item MCE::Loop->run_file ( sub { code }, file ) =item mce_loop_f { code } file The fastest of these is the /path/to/file. Workers communicate the next offset position among themselves without any interaction from the manager process. mce_loop_f { $_ } "/path/to/file"; mce_loop_f { $_ } $file_handle; mce_loop_f { $_ } \$scalar; =item MCE::Loop->run_seq ( sub { code }, $beg, $end [, $step, $fmt ] ) =item mce_loop_s { code } $beg, $end [, $step, $fmt ] Sequence can be defined as a list, an array reference, or a hash reference. The functions require both begin and end values to run. Step and format are optional. The format is passed to sprintf (% may be omitted below). my ($beg, $end, $step, $fmt) = (10, 20, 0.1, "%4.1f"); mce_loop_s { $_ } $beg, $end, $step, $fmt; mce_loop_s { $_ } [ $beg, $end, $step, $fmt ]; mce_loop_s { $_ } { begin => $beg, end => $end, step => $step, format => $fmt }; The sequence engine can compute 'begin' and 'end' items only, for the chunk, and not the items in between (hence boundaries only). This option applies to sequence only and has no effect when chunk_size equals 1. The time to run is 0.006s below. This becomes 0.827s without the bounds_only option due to computing all items in between, thus creating a very large array. Basically, specify bounds_only => 1 when boundaries is all you need for looping inside the block; e.g. Monte Carlo simulations. Time was measured using 1 worker to emphasize the difference. use MCE::Loop; MCE::Loop::init { max_workers => 1, chunk_size => 1_250_000, bounds_only => 1 }; ## For sequence, the input scalar $_ points to $chunk_ref ## when chunk_size > 1, otherwise $chunk_ref->[0]. ## ## mce_loop_s { ## my $begin = $_->[0]; my $end = $_->[-1]; ## ## for ($begin .. $end) { ## ... ## } ## ## } 1, 10_000_000; mce_loop_s { my ($mce, $chunk_ref, $chunk_id) = @_; ## $chunk_ref contains 2 items, not 1_250_000 my $begin = $chunk_ref->[ 0]; my $end = $chunk_ref->[-1]; ## or $chunk_ref->[1] MCE->printf("%7d .. %8d\n", $begin, $end); } 1, 10_000_000; -- Output 1 .. 1250000 1250001 .. 2500000 2500001 .. 3750000 3750001 .. 5000000 5000001 .. 6250000 6250001 .. 7500000 7500001 .. 8750000 8750001 .. 10000000 =back =head1 GATHERING DATA Unlike MCE::Map where gather and output order are done for you automatically, the gather method is used to have results sent back to the manager process. use MCE::Loop chunk_size => 1; ## Output order is not guaranteed. my @a = mce_loop { MCE->gather($_ * 2) } 1..100; print "@a\n\n"; ## Outputs to a hash instead (key, value). my %h1 = mce_loop { MCE->gather($_, $_ * 2) } 1..100; print "@h1{1..100}\n\n"; ## This does the same thing due to chunk_id starting at one. my %h2 = mce_loop { MCE->gather(MCE->chunk_id, $_ * 2) } 1..100; print "@h2{1..100}\n\n"; The gather method can be called multiple times within the block unlike return which would leave the block. Therefore, think of gather as yielding results immediately to the manager process without actually leaving the block. use MCE::Loop chunk_size => 1, max_workers => 3; my @hosts = qw( hosta hostb hostc hostd hoste ); my %h3 = mce_loop { my ($output, $error, $status); my $host = $_; ## Do something with $host; $output = "Worker ". MCE->wid .": Hello from $host"; if (MCE->chunk_id % 3 == 0) { ## Simulating an error condition local $? = 1; $status = $?; $error = "Error from $host" } else { $status = 0; } ## Ensure unique keys (key, value) when gathering to ## a hash. MCE->gather("$host.out", $output); MCE->gather("$host.err", $error) if (defined $error); MCE->gather("$host.sta", $status); } @hosts; foreach my $host (@hosts) { print $h3{"$host.out"}, "\n"; print $h3{"$host.err"}, "\n" if (exists $h3{"$host.err"}); print "Exit status: ", $h3{"$host.sta"}, "\n\n"; } -- Output Worker 2: Hello from hosta Exit status: 0 Worker 1: Hello from hostb Exit status: 0 Worker 3: Hello from hostc Error from hostc Exit status: 1 Worker 2: Hello from hostd Exit status: 0 Worker 1: Hello from hoste Exit status: 0 The following uses an anonymous array containing 3 elements when gathering data. Serialization is automatic behind the scene. my %h3 = mce_loop { ... MCE->gather($host, [$output, $error, $status]); } @hosts; foreach my $host (@hosts) { print $h3{$host}->[0], "\n"; print $h3{$host}->[1], "\n" if (defined $h3{$host}->[1]); print "Exit status: ", $h3{$host}->[2], "\n\n"; } Although MCE::Map comes to mind, one may want additional control when gathering data such as retaining output order. use MCE::Loop; sub preserve_order { my %tmp; my $order_id = 1; my $gather_ref = $_[0]; return sub { $tmp{ (shift) } = \@_; while (1) { last unless exists $tmp{$order_id}; push @{ $gather_ref }, @{ delete $tmp{$order_id++} }; } return; }; } my @m2; MCE::Loop::init { chunk_size => 'auto', max_workers => 'auto', gather => preserve_order(\@m2) }; mce_loop { my @a; my ($mce, $chunk_ref, $chunk_id) = @_; ## Compute the entire chunk data at once. push @a, map { $_ * 2 } @{ $chunk_ref }; ## Afterwards, invoke the gather feature, which ## will direct the data to the callback function. MCE->gather(MCE->chunk_id, @a); } 1..100000; MCE::Loop::finish; print scalar @m2, "\n"; All 6 models support 'auto' for chunk_size unlike the Core API. Think of the models as the basis for providing JIT for MCE. They create the instance, tune max_workers, and tune chunk_size automatically regardless of the hardware. The following does the same thing using the Core API. use MCE; sub preserve_order { ... } my $mce = MCE->new( max_workers => 'auto', chunk_size => 8000, user_func => sub { my @a; my ($mce, $chunk_ref, $chunk_id) = @_; ## Compute the entire chunk data at once. push @a, map { $_ * 2 } @{ $chunk_ref }; ## Afterwards, invoke the gather feature, which ## will direct the data to the callback function. MCE->gather(MCE->chunk_id, @a); } ); my @m2; $mce->process({ gather => preserve_order(\@m2) }, [1..100000]); $mce->shutdown; print scalar @m2, "\n"; =head1 MANUAL SHUTDOWN =over 3 =item MCE::Loop->finish =item MCE::Loop::finish Workers remain persistent as much as possible after running. Shutdown occurs automatically when the script terminates. Call finish when workers are no longer needed. use MCE::Loop; MCE::Loop::init { chunk_size => 20, max_workers => 'auto' }; mce_loop { ... } 1..100; MCE::Loop::finish; =back =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.810/lib/MCE/Util.pm0000644000175000017500000003315313022712430013553 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## Utility functions. ## ############################################################################### package MCE::Util; use strict; use warnings; no warnings qw( threads recursion uninitialized ); our $VERSION = '1.810'; ## no critic (BuiltinFunctions::ProhibitStringyEval) use Socket qw( PF_UNIX PF_UNSPEC SOCK_STREAM SOL_SOCKET SO_SNDBUF SO_RCVBUF ); use Time::HiRes qw( sleep time ); use base qw( Exporter ); use bytes; my ($_is_winenv, $_zero_bytes); BEGIN { $_is_winenv = ( $^O =~ /mswin|mingw|msys|cygwin/i ) ? 1 : 0; $_zero_bytes = "\x00\x00\x00\x00"; } our $LF = "\012"; Internals::SvREADONLY($LF, 1); our @EXPORT_OK = qw( $LF get_ncpu ); our %EXPORT_TAGS = ( all => \@EXPORT_OK ); ############################################################################### ## ---------------------------------------------------------------------------- ## The get_ncpu subroutine, largely adopted from Test::Smoke::Util.pm, ## returns the number of logical (online/active/enabled) CPU cores; ## never smaller than one. ## ## A warning is emitted to STDERR when it cannot recognize the operating ## system or the external command failed. ## ############################################################################### my $g_ncpu; sub get_ncpu { return $g_ncpu if (defined $g_ncpu); local $ENV{PATH} = "/usr/sbin:/sbin:/usr/bin:/bin:$ENV{PATH}"; $ENV{PATH} =~ /(.*)/; $ENV{PATH} = $1; ## Remove tainted'ness my $ncpu = 1; OS_CHECK: { local $_ = lc $^O; /linux/ && do { my ($count, $fh); if ( open $fh, '<', '/proc/stat' ) { $count = grep { /^cpu\d/ } <$fh>; close $fh; } $ncpu = $count if $count; last OS_CHECK; }; /bsd|darwin|dragonfly/ && do { chomp( my @output = `sysctl -n hw.ncpu 2>/dev/null` ); $ncpu = $output[0] if @output; last OS_CHECK; }; /aix/ && do { my @output = `pmcycles -m 2>/dev/null`; if (@output) { $ncpu = scalar @output; } else { @output = `lsdev -Cc processor -S Available 2>/dev/null`; $ncpu = scalar @output if @output; } last OS_CHECK; }; /gnu/ && do { chomp( my @output = `nproc 2>/dev/null` ); $ncpu = $output[0] if @output; last OS_CHECK; }; /hp-?ux/ && do { my $count = grep { /^processor/ } `ioscan -fkC processor 2>/dev/null`; $ncpu = $count if $count; last OS_CHECK; }; /irix/ && do { my @out = grep { /\s+processors?$/i } `hinv -c processor 2>/dev/null`; $ncpu = (split ' ', $out[0])[0] if @out; last OS_CHECK; }; /osf|solaris|sunos|svr5|sco/ && do { if (-x '/usr/sbin/psrinfo') { my $count = grep { /on-?line/ } `psrinfo 2>/dev/null`; $ncpu = $count if $count; } else { my @output = grep { /^NumCPU = \d+/ } `uname -X 2>/dev/null`; $ncpu = (split ' ', $output[0])[2] if @output; } last OS_CHECK; }; /mswin|mingw|msys|cygwin/ && do { if (exists $ENV{NUMBER_OF_PROCESSORS}) { $ncpu = $ENV{NUMBER_OF_PROCESSORS}; } last OS_CHECK; }; warn "MCE::Util::get_ncpu: command failed or unknown operating system\n"; } $ncpu = 1 if (!$ncpu || $ncpu < 1); return $g_ncpu = $ncpu; } ############################################################################### ## ---------------------------------------------------------------------------- ## Private methods. ## ############################################################################### sub _destroy_pipes { my ($_obj, @_params) = @_; local ($!, $?); local $SIG{__DIE__} = sub { }; for my $_p (@_params) { next unless (defined $_obj->{$_p}); if (ref $_obj->{$_p} eq 'ARRAY') { for my $_i (0 .. @{ $_obj->{$_p} } - 1) { next unless (defined $_obj->{$_p}[$_i]); close $_obj->{$_p}[$_i]; undef $_obj->{$_p}[$_i]; } } else { close $_obj->{$_p}; undef $_obj->{$_p}; } } return; } sub _destroy_socks { my ($_obj, @_params) = @_; local ($!, $?); local $SIG{__DIE__} = sub { }; for my $_p (@_params) { next unless (defined $_obj->{$_p}); if (ref $_obj->{$_p} eq 'ARRAY') { for my $_i (0 .. @{ $_obj->{$_p} } - 1) { next unless (defined $_obj->{$_p}[$_i]); if (fileno $_obj->{$_p}[$_i]) { syswrite($_obj->{$_p}[$_i], '0') if $_is_winenv; eval q{ CORE::shutdown($_obj->{$_p}[$_i], 2) }; } close $_obj->{$_p}[$_i]; undef $_obj->{$_p}[$_i]; } } else { if (fileno $_obj->{$_p}) { syswrite($_obj->{$_p}, '0') if $_is_winenv; eval q{ CORE::shutdown($_obj->{$_p}, 2) }; } close $_obj->{$_p}; undef $_obj->{$_p}; } } return; } sub _pipe_pair { my ($_obj, $_r_sock, $_w_sock, $_i) = @_; local ($|, $!); if (defined $_i) { pipe($_obj->{$_r_sock}[$_i], $_obj->{$_w_sock}[$_i]) or die "pipe: $!\n"; # IO::Handle->autoflush not available in older Perl. select(( select($_obj->{$_w_sock}[$_i]), $| = 1 )[0]); } else { pipe($_obj->{$_r_sock}, $_obj->{$_w_sock}) or die "pipe: $!\n"; select(( select($_obj->{$_w_sock}), $| = 1 )[0]); # Ditto. } return; } sub _sock_pair { my ($_obj, $_r_sock, $_w_sock, $_i, $_size) = @_; local ($|, $!); $_size = 16384 unless defined $_size; if (defined $_i) { socketpair( $_obj->{$_r_sock}[$_i], $_obj->{$_w_sock}[$_i], PF_UNIX, SOCK_STREAM, PF_UNSPEC ) or die "socketpair: $!\n"; if ($^O ne 'aix' && $^O ne 'linux') { setsockopt($_obj->{$_r_sock}[$_i], SOL_SOCKET, SO_SNDBUF, int $_size); setsockopt($_obj->{$_r_sock}[$_i], SOL_SOCKET, SO_RCVBUF, int $_size); setsockopt($_obj->{$_w_sock}[$_i], SOL_SOCKET, SO_SNDBUF, int $_size); setsockopt($_obj->{$_w_sock}[$_i], SOL_SOCKET, SO_RCVBUF, int $_size); } # IO::Handle->autoflush not available in older Perl. select(( select($_obj->{$_w_sock}[$_i]), $| = 1 )[0]); select(( select($_obj->{$_r_sock}[$_i]), $| = 1 )[0]); } else { socketpair( $_obj->{$_r_sock}, $_obj->{$_w_sock}, PF_UNIX, SOCK_STREAM, PF_UNSPEC ) or die "socketpair: $!\n"; if ($^O ne 'aix' && $^O ne 'linux') { setsockopt($_obj->{$_r_sock}, SOL_SOCKET, SO_SNDBUF, int $_size); setsockopt($_obj->{$_r_sock}, SOL_SOCKET, SO_RCVBUF, int $_size); setsockopt($_obj->{$_w_sock}, SOL_SOCKET, SO_SNDBUF, int $_size); setsockopt($_obj->{$_w_sock}, SOL_SOCKET, SO_RCVBUF, int $_size); } select(( select($_obj->{$_w_sock}), $| = 1 )[0]); # Ditto. select(( select($_obj->{$_r_sock}), $| = 1 )[0]); } return; } sub _sock_ready { my ($_socket, $_timeout) = @_; my $_val_bytes = "\x00\x00\x00\x00"; my $_ptr_bytes = unpack( 'I', pack('P', $_val_bytes) ); my ($_count, $_start) = (1, time); $_timeout += time if $_timeout; while (1) { # MSWin32 FIONREAD ioctl($_socket, 0x4004667f, $_ptr_bytes); return '' if $_val_bytes ne $_zero_bytes; return 1 if $_timeout && time > $_timeout; if ($_count) { # delay after a while to not consume a CPU core $_count = 0 if ++$_count % 50 == 0 && time - $_start > 0.005; next; } sleep 0.030; } } sub _parse_max_workers { my ($_max_workers) = @_; @_ = (); return $_max_workers unless (defined $_max_workers); if ($_max_workers =~ /^auto(?:$|\s*([\-\+\/\*])\s*(.+)$)/i) { my ($_ncpu_ul, $_ncpu); $_ncpu_ul = $_ncpu = get_ncpu(); $_ncpu_ul = 8 if ($_ncpu_ul > 8); if ($1 && $2) { local $@; $_max_workers = eval "int($_ncpu_ul $1 $2 + 0.5)"; $_max_workers = 1 if (!$_max_workers || $_max_workers < 1); $_max_workers = $_ncpu if ($_max_workers > $_ncpu); } else { $_max_workers = $_ncpu_ul; } } return $_max_workers; } sub _parse_chunk_size { my ($_chunk_size, $_max_workers, $_params, $_input_data, $_array_size) = @_; @_ = (); return $_chunk_size if (!defined $_chunk_size || !defined $_max_workers); if (defined $_params && exists $_params->{chunk_size}) { $_chunk_size = $_params->{chunk_size}; } if ($_chunk_size =~ /([0-9\.]+)K\z/i) { $_chunk_size = int($1 * 1024 + 0.5); } elsif ($_chunk_size =~ /([0-9\.]+)M\z/i) { $_chunk_size = int($1 * 1024 * 1024 + 0.5); } if ($_chunk_size eq 'auto') { if ( (defined $_params && ref $_params->{input_data} eq 'CODE') || (defined $_input_data && ref $_input_data eq 'CODE') ) { # Iterators may optionally use chunk_size to determine how much # to return per iteration. The default is 1 for MCE Models, same # as for the Core API. The user_func receives an array_ref # regardless if 1 or higher. # # sub make_iter { # ... # return sub { # my ($chunk_size) = @_; # ... # }; # } return 1; } my $_size = (defined $_input_data && ref $_input_data eq 'ARRAY') ? scalar @{ $_input_data } : $_array_size; my $_is_file; if (defined $_params && exists $_params->{sequence}) { my ($_begin, $_end, $_step); if (ref $_params->{sequence} eq 'HASH') { $_begin = $_params->{sequence}->{begin}; $_end = $_params->{sequence}->{end}; $_step = $_params->{sequence}->{step} || 1; } else { $_begin = $_params->{sequence}[0]; $_end = $_params->{sequence}[1]; $_step = $_params->{sequence}[2] || 1; } if (!defined $_input_data && !$_array_size) { $_size = abs($_end - $_begin) / $_step + 1; } } elsif (defined $_params && exists $_params->{_file}) { my $_ref = ref $_params->{_file}; if ($_ref eq 'SCALAR') { $_size = length ${ $_params->{_file} }; } elsif ($_ref eq '') { $_size = -s $_params->{_file}; } else { $_size = 0; $_chunk_size = 393_216; # 384K } $_is_file = 1; } elsif (defined $_input_data) { if (ref($_input_data) =~ /^(?:GLOB|FileHandle|IO::)/) { $_is_file = 1; $_size = 0; $_chunk_size = 393_216; # 384K } elsif (ref $_input_data eq 'SCALAR') { $_is_file = 1; $_size = length ${ $_input_data }; } } if (defined $_is_file) { if ($_size) { $_chunk_size = int($_size / $_max_workers / 24 + 0.5); $_chunk_size = 5_242_880 if $_chunk_size > 5_242_880; # 5M $_chunk_size = 2 if $_chunk_size <= 8192; } } else { $_chunk_size = int($_size / $_max_workers / 24 + 0.5); $_chunk_size = 8000 if $_chunk_size > 8000; $_chunk_size = 2 if $_chunk_size < 2; } } return $_chunk_size; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Util - Utility functions =head1 VERSION This document describes MCE::Util version 1.810 =head1 SYNOPSIS use MCE::Util; =head1 DESCRIPTION A utility module for MCE. Nothing is exported by default. Exportable is get_ncpu. =head2 get_ncpu() Returns the number of logical (online/active/enabled) CPU cores; never smaller than one. my $ncpu = MCE::Util::get_ncpu(); Specifying 'auto' for max_workers calls MCE::Util::get_ncpu automatically. MCE 1.521 sets an upper-limit when specifying 'auto'. The reason is mainly to safeguard apps from spawning 100 workers on a box having 100 cores. This is important for apps which are IO-bound. use MCE; ## 'Auto' is the total # of logical cores (lcores) (8 maximum, MCE 1.521). ## The computed value will not exceed the # of logical cores on the box. my $mce = MCE->new( max_workers => 'auto', ## 1 on HW with 1-lcores; 2 on 2-lcores max_workers => 16, ## 16 on HW with 4-lcores; 16 on 32-lcores max_workers => 'auto', ## 4 on HW with 4-lcores; 8 on 16-lcores max_workers => 'auto*1.5', ## 4 on HW with 4-lcores; 12 on 16-lcores max_workers => 'auto*2.0', ## 4 on HW with 4-lcores; 16 on 16-lcores max_workers => 'auto/2.0', ## 2 on HW with 4-lcores; 4 on 16-lcores max_workers => 'auto+3', ## 4 on HW with 4-lcores; 11 on 16-lcores max_workers => 'auto-1', ## 3 on HW with 4-lcores; 7 on 16-lcores max_workers => MCE::Util::get_ncpu, ## run on all lcores ); In summary: 1. Auto has an upper-limit of 8 in MCE 1.521 (# of lcores, 8 maximum) 2. Math can be applied with auto (*/+-) to change the upper limit 3. The computed value for auto will not exceed the total # of lcores 4. One can specify max_workers explicitly to a hard value 5. MCE::Util::get_ncpu returns the actual # of lcores =head1 ACKNOWLEDGMENTS The portable code for detecting the number of processors was adopted from L. =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.810/lib/MCE/Examples.pod0000644000175000017500000007024413022712373014572 0ustar mariomario =head1 NAME MCE::Examples - Various examples and demonstrations =head1 VERSION This document describes MCE::Examples version 1.810 =head1 INCLUDED WITH THE DISTRIBUTION A wrapper script for parallelizing the grep binary. Hence, processing is done by the binary, not Perl. This wrapper resides under the bin directory. mce_grep A wrapper script with support for the following C binaries. agrep, grep, egrep, fgrep, and tre-agrep Chunking may be applied either at the [file] level, for large file(s), or at the [list] level when parsing many files recursively. The gain in performance is noticeable for expensive patterns, especially with agrep and tre-agrep. =head1 MCE EXAMPLES ON GITHUB The examples directory, beginning with 1.700, is maintained separately at a Github repository L and no longer included with the Perl MCE distribution. =head1 PROCESSING INPUT DATA The next section describes ways to process input data in MCE. =head2 CHUNK_SIZE => 1 (in essence, disabling chunking) Imagine a long running process and wanting to parallelize an array against a pool of workers. The sequence option may be used if simply wanting to loop through a sequence of numbers instead. Below, a callback function is used for displaying results. The logic shows how one can output results immediately while still preserving output order as if processing serially. The %tmp hash is a temporary cache for out-of-order results. use MCE; ## Return an iterator for preserving output order. sub preserve_order { my (%result_n, %result_d); my $order_id = 1; return sub { my ($chunk_id, $n, $data) = @_; $result_n{ $chunk_id } = $n; $result_d{ $chunk_id } = $data; while (1) { last unless exists $result_d{$order_id}; printf "n: %5d sqrt(n): %7.3f\n", $result_n{$order_id}, $result_d{$order_id}; delete $result_n{$order_id}; delete $result_d{$order_id}; $order_id++; } return; }; } ## Use $chunk_ref->[0] or $_ to retrieve the element. my @input_data = (0 .. 18000 - 1); my $mce = MCE->new( gather => preserve_order, input_data => \@input_data, chunk_size => 1, max_workers => 3, user_func => sub { my ($mce, $chunk_ref, $chunk_id) = @_; MCE->gather($chunk_id, $_, sqrt($_)); } ); $mce->run; This does the same thing using the foreach "sugar" method. use MCE; sub preserve_order { ... } my $mce = MCE->new( chunk_size => 1, max_workers => 3, gather => preserve_order ); ## Use $chunk_ref->[0] or $_ to retrieve the element. my @input_data = (0 .. 18000 - 1); $mce->foreach( \@input_data, sub { my ($mce, $chunk_ref, $chunk_id) = @_; MCE->gather($chunk_id, $_, sqrt($_)); }); The 2 examples described above were done using the Core API. MCE 1.5 comes with several models. The L model is used below. use MCE::Loop; sub preserve_order { ... } MCE::Loop::init { chunk_size => 1, max_workers => 3, gather => preserve_order }; ## Use $chunk_ref->[0] or $_ to retrieve the element. my @input_data = (0 .. 18000 - 1); mce_loop { my ($mce, $chunk_ref, $chunk_id) = @_; MCE->gather($chunk_id, $_, sqrt($_)); } @input_data; MCE::Loop::finish; =head2 CHUNKING INPUT DATA Chunking has the effect of reducing IPC overhead by many folds. A chunk containing $chunk_size items is sent to the next available worker. use MCE; ## Return an iterator for preserving output order. sub preserve_order { my (%result_n, %result_d, $size); my $order_id = 1; return sub { my ($chunk_id, $n_ref, $data_ref) = @_; $result_n{ $chunk_id } = $n_ref; $result_d{ $chunk_id } = $data_ref; while (1) { last unless exists $result_d{$order_id}; $size = @{ $result_d{$order_id} }; for (0 .. $size - 1) { printf "n: %5d sqrt(n): %7.3f\n", $result_n{$order_id}->[$_], $result_d{$order_id}->[$_]; } delete $result_n{$order_id}; delete $result_d{$order_id}; $order_id++; } return; }; } ## Chunking requires one to loop inside the code block. my @input_data = (0 .. 18000 - 1); my $mce = MCE->new( gather => preserve_order, input_data => \@input_data, chunk_size => 500, max_workers => 3, user_func => sub { my ($mce, $chunk_ref, $chunk_id) = @_; my (@n, @result); foreach ( @{ $chunk_ref } ) { push @n, $_; push @result, sqrt($_); } MCE->gather($chunk_id, \@n, \@result); } ); $mce->run; This does the same thing using the forchunk "sugar" method. use MCE; sub preserve_order { ... } my $mce = MCE->new( chunk_size => 500, max_workers => 3, gather => preserve_order ); ## Chunking requires one to loop inside the code block. my @input_data = (0 .. 18000 - 1); $mce->forchunk( \@input_data, sub { my ($mce, $chunk_ref, $chunk_id) = @_; my (@n, @result); foreach ( @{ $chunk_ref } ) { push @n, $_; push @result, sqrt($_); } MCE->gather($chunk_id, \@n, \@result); }); Finally, chunking with the L model. use MCE::Loop; sub preserve_order { ... } MCE::Loop::init { chunk_size => 500, max_workers => 3, gather => preserve_order }; ## Chunking requires one to loop inside the code block. my @input_data = (0 .. 18000 - 1); mce_loop { my ($mce, $chunk_ref, $chunk_id) = @_; my (@n, @result); foreach ( @{ $chunk_ref } ) { push @n, $_; push @result, sqrt($_); } MCE->gather($chunk_id, \@n, \@result); } @input_data; MCE::Loop::finish; =head1 DEMO APPLYING SEQUENCES WITH USER_TASKS The following is an extract from the seq_demo.pl example included with MCE. Think of having several MCEs running in parallel. The sequence and chunk_size options may be specified uniquely per each task. The input scalar $_ (not shown below) contains the same value as $seq_n in user_func. use MCE; use Time::HiRes 'sleep'; ## Run with seq_demo.pl | sort sub user_func { my ($mce, $seq_n, $chunk_id) = @_; my $wid = MCE->wid; my $task_id = MCE->task_id; my $task_wid = MCE->task_wid; if (ref $seq_n eq 'ARRAY') { ## seq_n or $_ is an array reference when chunk_size > 1 foreach (@{ $seq_n }) { MCE->printf( "task_id %d: seq_n %s: chunk_id %d: wid %d: task_wid %d\n", $task_id, $_, $chunk_id, $wid, $task_wid ); } } else { MCE->printf( "task_id %d: seq_n %s: chunk_id %d: wid %d: task_wid %d\n", $task_id, $seq_n, $chunk_id, $wid, $task_wid ); } sleep 0.003; return; } ## Each task can be configured uniquely. my $mce = MCE->new( user_tasks => [{ max_workers => 2, chunk_size => 1, sequence => { begin => 11, end => 19, step => 1 }, user_func => \&user_func },{ max_workers => 2, chunk_size => 5, sequence => { begin => 21, end => 29, step => 1 }, user_func => \&user_func },{ max_workers => 2, chunk_size => 3, sequence => { begin => 31, end => 39, step => 1 }, user_func => \&user_func }] ); $mce->run; -- Output task_id 0: seq_n 11: chunk_id 1: wid 2: task_wid 2 task_id 0: seq_n 12: chunk_id 2: wid 1: task_wid 1 task_id 0: seq_n 13: chunk_id 3: wid 2: task_wid 2 task_id 0: seq_n 14: chunk_id 4: wid 1: task_wid 1 task_id 0: seq_n 15: chunk_id 5: wid 2: task_wid 2 task_id 0: seq_n 16: chunk_id 6: wid 1: task_wid 1 task_id 0: seq_n 17: chunk_id 7: wid 2: task_wid 2 task_id 0: seq_n 18: chunk_id 8: wid 1: task_wid 1 task_id 0: seq_n 19: chunk_id 9: wid 2: task_wid 2 task_id 1: seq_n 21: chunk_id 1: wid 3: task_wid 1 task_id 1: seq_n 22: chunk_id 1: wid 3: task_wid 1 task_id 1: seq_n 23: chunk_id 1: wid 3: task_wid 1 task_id 1: seq_n 24: chunk_id 1: wid 3: task_wid 1 task_id 1: seq_n 25: chunk_id 1: wid 3: task_wid 1 task_id 1: seq_n 26: chunk_id 2: wid 4: task_wid 2 task_id 1: seq_n 27: chunk_id 2: wid 4: task_wid 2 task_id 1: seq_n 28: chunk_id 2: wid 4: task_wid 2 task_id 1: seq_n 29: chunk_id 2: wid 4: task_wid 2 task_id 2: seq_n 31: chunk_id 1: wid 5: task_wid 1 task_id 2: seq_n 32: chunk_id 1: wid 5: task_wid 1 task_id 2: seq_n 33: chunk_id 1: wid 5: task_wid 1 task_id 2: seq_n 34: chunk_id 2: wid 6: task_wid 2 task_id 2: seq_n 35: chunk_id 2: wid 6: task_wid 2 task_id 2: seq_n 36: chunk_id 2: wid 6: task_wid 2 task_id 2: seq_n 37: chunk_id 3: wid 5: task_wid 1 task_id 2: seq_n 38: chunk_id 3: wid 5: task_wid 1 task_id 2: seq_n 39: chunk_id 3: wid 5: task_wid 1 =head1 GLOBALLY SCOPED VARIABLES AND MCE MODELS It is possible that Perl may create a new code ref on subsequent runs causing MCE models to re-spawn. One solution to this is to declare global variables, referenced by workers, with "our" instead of "my". Let's take a look. The $i variable is declared with my and being reference in both user_begin and mce_loop blocks. This will cause Perl to create a new code ref for mce_loop on subsequent runs. use MCE::Loop; my $i = 0; ## <-- this is the reason, try our instead MCE::Loop::init { user_begin => sub { print "process_id: $$\n" if MCE->wid == 1; $i++; }, chunk_size => 1, max_workers => 'auto', }; for (1..2) { ## Perl creates another code block ref causing workers ## to re-spawn on subsequent runs. print "\n"; mce_loop { print "$i: $_\n" } 1..4; } MCE::Loop::finish; -- Output process_id: 51380 1: 1 1: 2 1: 3 1: 4 process_id: 51388 1: 1 1: 2 1: 3 1: 4 By making the one line change, we see that workers persist for the duration of the script. use MCE::Loop; our $i = 0; ## <-- changed my to our MCE::Loop::init { user_begin => sub { print "process_id: $$\n" if MCE->wid == 1; $i++; }, chunk_size => 1, max_workers => 'auto', }; for (1..2) { ## Workers persist between runs. No re-spawning. print "\n"; mce_loop { print "$i: $_\n" } 1..4; } -- Output process_id: 51457 1: 1 1: 2 1: 4 1: 3 process_id: 51457 2: 1 2: 2 2: 3 2: 4 One may alternatively specify a code reference to existing routines for user_begin and mce_loop. Take notice of the comma after \&_func though. use MCE::Loop; my $i = 0; ## my (ok) sub _begin { print "process_id: $$\n" if MCE->wid == 1; $i++; } sub _func { print "$i: $_\n"; } MCE::Loop::init { user_begin => \&_begin, chunk_size => 1, max_workers => 'auto', }; for (1..2) { print "\n"; mce_loop \&_func, 1..4; } MCE::Loop::finish; -- Output process_id: 51626 1: 1 1: 2 1: 3 1: 4 process_id: 51626 2: 1 2: 2 2: 3 2: 4 =head1 MANDELBROT DEMONSTRATION For the next demonstration, L allows a section of code to run serially and orderly between workers. Relay capabilities is enabled with the C option, which loads MCE::Relay. # perl mandelbrot.pl 16000 > image.pbm # outputs a pbm binary to STDOUT # The Computer Language Benchmarks Game # http://benchmarksgame.alioth.debian.org/ # # Started with: # C# : Adapted by Antti Lankila from Isaac Gouy's implementation # Perl: Contributed by Mykola Zubach # # MCE::Loop version by Mario Roy # requires MCE 1.807+ use strict; use warnings; use MCE::Loop; use constant MAXITER => 50; use constant LIMIT => 4.0; use constant XMIN => -1.5; use constant YMIN => -1.0; my ( $w, $h, $m, $invN ); sub draw_lines { my ( $y1, $y2 ) = @_; my @result; # Workers run simultaneously, in parallel. for my $y ( $y1 .. $y2 ) { my ( $bits, $xcounter, @line ) = ( 0, 0 ); my $Ci = $y * $invN + YMIN; for my $x ( 0 .. $w - 1 ) { my ( $Zr, $Zi, $Tr, $Ti ) = ( 0, 0, 0, 0 ); my $Cr = $x * $invN + XMIN; $bits = $bits << 1; for ( 1 .. MAXITER ) { $Zi = $Zi * 2 * $Zr + $Ci; $Zr = $Tr - $Ti + $Cr; $Ti = $Zi * $Zi, $Tr = $Zr * $Zr; $bits |= 1, last if ( $Tr + $Ti > LIMIT ); } if ( ++$xcounter == 8 ) { push @line, $bits ^ 0xff; $bits = $xcounter = 0; } } if ( $xcounter ) { push @line, ( $bits << ( 8 - $xcounter ) ) ^ 0xff; } push @result, pack 'C*', @line; } # Statements between lock & unlock are processed serially & orderly. MCE->relay_lock; print @result; # Workers display upper-half only. MCE->gather( @result ); # Gather lines for the manager-process. MCE->relay_unlock; } ## MAIN() # Important, must flush output immediately. $| = 1; binmode STDOUT; $w = $h = shift || 200; $m = int( $h / 2 ); $invN = 2 / $w; print "P4\n$w $h\n"; # PBM image header. # Workers display upper-half only. Also, lines are gathered to be # displayed later by the manager-process after running. MCE::Loop->init( init_relay => 0, # Enables MCE::Relay capabilities if defined. max_workers => 4, bounds_only => 1, ); my @upper = mce_loop_s { draw_lines( $_[1][0], $_[1][1] ) } 0, $m; MCE::Loop->finish; # Remove first and last lines from the upper half. # Then, output bottom half. shift @upper, pop @upper; print reverse @upper; =head1 MONTE CARLO SIMULATION There is an article on the web (search for comp.lang.perl.misc MCE) suggesting that MCE::Examples does not cover a simple simulation scenario. This section demonstrates just that. The serial code is based off the one by "gamo". A sleep is added to imitate extra CPU time. The while loop is wrapped within a for loop to run 10 times. The random number generator is seeded as well. use Time::HiRes qw/sleep time/; srand 5906; my ($var, $foo, $bar) = (1, 2, 3); my ($r, $a, $b); my $start = time; for (1..10) { while (1) { $r = rand; $a = $r * ($var + $foo + $bar); $b = sqrt($var + $foo + $bar); last if ($a < $b + 0.001 && $a > $b - 0.001); sleep 0.002; } print "$r -> $a\n"; } my $end = time; printf {*STDERR} "\n## compute time: %0.03f secs\n\n", $end - $start; -- Output 0.408246276657106 -> 2.44947765994264 0.408099657137821 -> 2.44859794282693 0.408285842931324 -> 2.44971505758794 0.408342292008765 -> 2.45005375205259 0.408333076522673 -> 2.44999845913604 0.408344266898869 -> 2.45006560139321 0.408084104120526 -> 2.44850462472316 0.408197400014714 -> 2.44918440008828 0.408344783704855 -> 2.45006870222913 0.408248062985479 -> 2.44948837791287 ## compute time: 93.049 secs Next, we'd do the same with MCE. The demonstration requires at least MCE 1.509 to run properly. Folks on prior releases (1.505 - 1.508) will not see output for the 2nd run and beyond. use Time::HiRes qw/sleep time/; use MCE::Loop; srand 5906; ## Configure MCE. Move common variables inside the user_begin ## block when not needed by the manager process. MCE::Loop::init { user_begin => sub { use vars qw($var $foo $bar); our ($var, $foo, $bar) = (1, 2, 3); }, chunk_size => 1, max_workers => 'auto', input_data => \&_input, gather => \&_gather }; ## Callback functions. my ($done, $r, $a); sub _input { return if $done; return rand; } sub _gather { my ($_r, $_a, $_b) = @_; return if $done; if ($_a < $_b + 0.001 && $_a > $_b - 0.001) { ($done, $r, $a) = (1, $_r, $_a); } return; } ## Compute in parallel. my $start = time; for (1..10) { $done = 0; ## Reset $done before running mce_loop { # my ($mce, $chunk_ref, $chunk_id) = @_; # my $r = $chunk_ref->[0]; my $r = $_; ## Valid due to chunk_size => 1 my $a = $r * ($var + $foo + $bar); my $b = sqrt($var + $foo + $bar); MCE->gather($r, $a, $b); sleep 0.002; }; print "$r -> $a\n"; } printf "\n## compute time: %0.03f secs\n\n", time - $start; -- Output 0.408246276657106 -> 2.44947765994264 0.408099657137821 -> 2.44859794282693 0.408285842931324 -> 2.44971505758794 0.408342292008765 -> 2.45005375205259 0.408333076522673 -> 2.44999845913604 0.408344266898869 -> 2.45006560139321 0.408084104120526 -> 2.44850462472316 0.408197400014714 -> 2.44918440008828 0.408344783704855 -> 2.45006870222913 0.408248062985479 -> 2.44948837791287 ## compute time: 12.990 secs Well, there you have it. MCE is able to complete the same simulation many times faster. =head1 MANY WORKERS RUNNING IN PARALLEL There are occasions when one wants several workers to run in parallel without having to specify input_data or sequence. These two options are optional in MCE. The "do" and "sendto" methods, for sending data to the manager process, are demonstrated below. Both process serially by the manager process on a first come, first serve basis. use MCE::Flow max_workers => 4; sub report_stats { my ($wid, $msg, $h_ref) = @_; print "Worker $wid says $msg: ", $h_ref->{"counter"}, "\n"; } mce_flow sub { my ($mce) = @_; my $wid = MCE->wid; if ($wid == 1) { my %h = ("counter" => 0); while (1) { $h{"counter"} += 1; MCE->do("report_stats", $wid, "Hey there", \%h); last if ($h{"counter"} == 4); sleep 2; } } else { my %h = ("counter" => 0); while (1) { $h{"counter"} += 1; MCE->do("report_stats", $wid, "Welcome..", \%h); last if ($h{"counter"} == 2); sleep 4; } } MCE->print(\*STDERR, "Worker $wid is exiting\n"); }; -- Output Note how worker 2 comes first in the 2nd run below. $ ./demo.pl Worker 1 says Hey there: 1 Worker 2 says Welcome..: 1 Worker 3 says Welcome..: 1 Worker 4 says Welcome..: 1 Worker 1 says Hey there: 2 Worker 2 says Welcome..: 2 Worker 3 says Welcome..: 2 Worker 1 says Hey there: 3 Worker 2 is exiting Worker 3 is exiting Worker 4 says Welcome..: 2 Worker 4 is exiting Worker 1 says Hey there: 4 Worker 1 is exiting $ ./demo.pl Worker 2 says Welcome..: 1 Worker 1 says Hey there: 1 Worker 4 says Welcome..: 1 Worker 3 says Welcome..: 1 Worker 1 says Hey there: 2 Worker 2 says Welcome..: 2 Worker 4 says Welcome..: 2 Worker 3 says Welcome..: 2 Worker 2 is exiting Worker 4 is exiting Worker 1 says Hey there: 3 Worker 3 is exiting Worker 1 says Hey there: 4 Worker 1 is exiting =head1 TESTING AND CAPTURING OUTPUT Capturing C and C is possible with L. MCE v1.708 or later is required to run the demonstration. use App::Cmd::Tester; use MCE; my $mce = MCE->new( max_workers => 4, user_func => sub { my $wid = MCE->wid; # MCE->sendto('stderr', "$wid: sendto err\n"); # MCE->sendto(\*STDERR, "$wid: sendto err\n"); MCE->print(\*STDERR, "$wid: print err\n"); # MCE->sendto('stdout', "$wid: sendto out\n"); # MCE->sendto(\*STDOUT, "$wid: sendto out\n"); # MCE->print(\*STDOUT, "$wid: print out\n"); MCE->print("$wid: print out\n"); } ); my $result = test_app( $mce => [] ); print "# stderr\n"; print $result->stderr; print "\n"; print "# stdout\n"; print $result->stdout; print "\n"; print "# output\n"; print $result->output; print "\n"; print "# exit code\n"; print $result->exit_code; print "\n\n"; -- Output # stderr 3: print err 4: print err 1: print err 2: print err # stdout 3: print out 4: print out 1: print out 2: print out # output 3: print err 3: print out 4: print err 1: print err 4: print out 1: print out 2: print err 2: print out # exit code 0 The next demonstration captures a sequence of numbers orderly. The slot name for C must be C or C for MCE->print to work. use MCE::Flow; use MCE::Candy; use IO::TieCombine; my $hub = IO::TieCombine->new; { tie local *STDOUT, $hub, 'stdout'; MCE::Flow::init { max_workers => 4, chunk_size => 500, bounds_only => 1, gather => MCE::Candy::out_iter_fh(\*STDOUT), }; mce_flow_s sub { my ($mce, $seq, $chunk_id) = @_; my $output = ''; for my $n ( $seq->[0] .. $seq->[1] ) { $output .= "$n\n"; } # do this if output order is not required # $mce->print(\*STDOUT, $output); # or this if preserving output order is desired $mce->gather($chunk_id, $output); }, 1, 100000; MCE::Flow::finish; } my $content = $hub->slot_contents('stdout'); my $answer = join("", map { "$_\n" } 1..100000); if ($content eq $answer) { print "ordered: yes\n"; } else { print "ordered: no\n"; } -- Output ordered: yes =head1 FCGI::PROCMANAGER DEMONSTRATIONS The demonstrations requires MCE 1.804 to run. Otherwise, the MCE C option must be specified and set to 1. This applies to UNIX only and set automatically in 1.804 when C<(F)CGI.pm> is present. #!/usr/bin/perl # http://127.0.0.1/cgi-bin/test_mce1.fcgi # http://127.0.0.1/cgi-bin/test_mce1.fcgi?size=8 use strict; use warnings; use MCE::Map max_workers => 3; use CGI::Fast; use FCGI::ProcManager; my $count = 0; my $proc_manager = FCGI::ProcManager->new({ n_processes => 4 }); $proc_manager->pm_manage(); while ( my $query = CGI::Fast->new() ) { $proc_manager->pm_pre_dispatch(); print "Content-type: text/html\r\n\r\n"; print "$$: ", ++$count, "
\n"; print "
\n"; print "$_ = $ENV{$_}
\n" foreach sort keys %ENV; print "
\n"; my %params; foreach ( sort $query->param() ) { $params{$_} = $query->param($_); print $_, " = ", $params{$_}, "
\n"; } print "
\n"; my @ret = mce_map { "$$: ".( $_ * 2 ) } 1 .. $params{'size'} || 8; print join("
\n", @ret), "
\n"; $proc_manager->pm_post_dispatch(); } Initializing MCE options before calling C is not recommended. The following is one way to do it and does the same thing. #!/usr/bin/perl # http://127.0.0.1/cgi-bin/test_mce2.fcgi # http://127.0.0.1/cgi-bin/test_mce2.fcgi?size=8 use strict; use warnings; use MCE::Map; use CGI::Fast; use FCGI::ProcManager; my ($first_time, $count) = (1, 0); my $proc_manager = FCGI::ProcManager->new({ n_processes => 4 }); $proc_manager->pm_manage(); while ( my $query = CGI::Fast->new() ) { $proc_manager->pm_pre_dispatch(); print "Content-type: text/html\r\n\r\n"; print "$$: ", ++$count, "
\n"; print "
\n"; print "$_ = $ENV{$_}
\n" foreach sort keys %ENV; print "
\n"; my %params; foreach ( sort $query->param() ) { $params{$_} = $query->param($_); print $_, " = ", $params{$_}, "
\n"; } print "
\n"; if ( $first_time ) { MCE::Map::init( max_workers => 3 ); } my @ret = mce_map { "$$: ".( $_ * 2 ) } 1 .. $params{'size'} || 8; print join("
\n", @ret), "
\n"; $proc_manager->pm_post_dispatch(); } Sharing data is possible via C between C and C workers. The following is a demonstration utilizing a shared counter variable which increments by one regardless of the C worker serving the request. #!/usr/bin/perl # http://127.0.0.1/cgi-bin/test_mce3.fcgi # http://127.0.0.1/cgi-bin/test_mce3.fcgi?size=8 use strict; use warnings; use MCE::Map; use MCE::Shared; use CGI::Fast; use FCGI::ProcManager; # Shared variables must be defined before FCGI::ProcManager. my $count = MCE::Shared->scalar( 0 ); my $first_time = 1; my $proc_manager = FCGI::ProcManager->new({ n_processes => 4 }); $proc_manager->pm_manage(); # Optional, the following statement must come after $pm->pm_manage. MCE::Shared->init(); # enables shared parallel-IPC capabilities while ( my $query = CGI::Fast->new() ) { $proc_manager->pm_pre_dispatch(); print "Content-type: text/html\r\n\r\n"; print "$$: ", $count->incr(), "
\n"; print "
\n"; print "$_ = $ENV{$_}
\n" foreach sort keys %ENV; print "
\n"; my %params; foreach ( sort $query->param() ) { $params{$_} = $query->param($_); print $_, " = ", $params{$_}, "
\n"; } print "
\n"; if ( $first_time ) { MCE::Map->init( max_workers => 3 ); $first_time = 0; } my @ret = mce_map { "$$: ".( $_ * 2 ) } 1 .. $params{'size'} || 8; print join("
\n", @ret), "
\n"; $proc_manager->pm_post_dispatch(); } Resetting the environment is helpful during development. The shared-manager process stops immediately upon receiving the C signal. killall -TERM perl-fcgi perl-fcgi-pm ; service httpd restart =head1 TK DEMONSTRATIONS The demonstrations requires MCE 1.805 to run. Otherwise, the MCE C option must be specified and set to 1. This applies to UNIX only and set automatically in 1.805 when C is present. #!/usr/bin/perl use strict; use warnings; use MCE; use Tk; my $mw = new MainWindow -title => 'MCE/Tk Test'; $mw->geometry( '300x300' ); $mw->Button( -text => "Test MCE", -command => \&test_mce )->pack(); my $frame = $mw->Frame->pack( -fill => 'x' ); my $mce = MCE->new( max_workers => 4, user_func => sub { my @args = @{ MCE->user_args() }; print MCE->pid(), ": $_\n"; }, )->spawn; MainLoop; # Do not call $mce->shutdown on Windows ($^O eq 'MSWin32'). # Workers terminate with the application. # # $mce->shutdown(); print "Exiting...\n"; sub test_mce { $mce->process({ user_args => [ 'arg1', 'arg2', 'argN' ], input_data => [ 1 .. 10 ], chunk_size => 1, }); } The following demonstration does the same thing via MCE::Flow. #!/usr/bin/perl use strict; use warnings; use MCE::Flow max_workers => 4; use Tk; my $mw = new MainWindow -title => 'MCE/Tk Test'; $mw->geometry( '300x300' ); $mw->Button( -text => "Test MCE", -command => \&test_mce )->pack(); my $frame = $mw->Frame->pack( -fill => 'x' ); sub task { my @args = @{ MCE->user_args() }; print MCE->pid(), ": $_\n"; } MainLoop; print "Exiting...\n"; sub test_mce { MCE::Flow->init( user_args => [ 'arg1', 'arg2', 'argN' ], chunk_size => 1 ); MCE::Flow->run( \&task, [ 1 .. 10 ] ); } MCE::Hobo 1.804 or later is another possibility if running on a UNIX platform. #!/usr/bin/perl use strict; use warnings; use MCE::Hobo; use Tk; my $mw = new MainWindow -title => 'MCE/Tk Test'; $mw->geometry( '300x300' ); $mw->Button( -text => "Test MCE", -command => \&test_mce )->pack(); my $frame = $mw->Frame->pack( -fill => 'x' ); sub task { my @args = @_; print MCE::Hobo->pid(), ": $_\n"; } MainLoop; print "Exiting...\n"; sub test_mce { MCE::Hobo->create(\&task, 'arg1', 'arg2', 'argN') for ( 1 .. 4 ); MCE::Hobo->waitall(); } =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.810/lib/MCE/Step.pm0000644000175000017500000013036413022712421013553 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## Parallel step model for building creative steps. ## ############################################################################### package MCE::Step; use strict; use warnings; no warnings qw( threads recursion uninitialized ); our $VERSION = '1.810'; ## no critic (BuiltinFunctions::ProhibitStringyEval) ## no critic (Subroutines::ProhibitSubroutinePrototypes) ## no critic (TestingAndDebugging::ProhibitNoStrict) use Scalar::Util qw( looks_like_number ); use MCE; use MCE::Queue; our @CARP_NOT = qw( MCE ); my $_has_threads = $INC{'threads.pm'} ? 1 : 0; my $_tid = $_has_threads ? threads->tid() : 0; sub CLONE { $_tid = threads->tid() if $_has_threads; } ############################################################################### ## ---------------------------------------------------------------------------- ## Import routine. ## ############################################################################### my ($_MCE, $_def, $_params, $_tag) = ({}, {}, {}, 'MCE::Step'); my ($_prev_c, $_prev_n, $_prev_t, $_prev_w) = ({}, {}, {}, {}); my ($_user_tasks, $_queue, $_last_task_id, $_lkup) = ({}, {}, {}, {}); sub import { my ($_class, $_pkg) = (shift, caller); my $_p = $_def->{$_pkg} = { MAX_WORKERS => 'auto', CHUNK_SIZE => 'auto', FAST => 0, }; ## Import functions. no strict 'refs'; no warnings 'redefine'; *{ $_pkg.'::mce_step_f' } = \&run_file; *{ $_pkg.'::mce_step_s' } = \&run_seq; *{ $_pkg.'::mce_step' } = \&run; ## Process module arguments. while ( my $_argument = shift ) { my $_arg = lc $_argument; $_p->{MAX_WORKERS} = shift, next if ( $_arg eq 'max_workers' ); $_p->{CHUNK_SIZE} = shift, next if ( $_arg eq 'chunk_size' ); $_p->{TMP_DIR} = shift, next if ( $_arg eq 'tmp_dir' ); $_p->{FREEZE} = shift, next if ( $_arg eq 'freeze' ); $_p->{THAW} = shift, next if ( $_arg eq 'thaw' ); $_p->{FAST} = shift, next if ( $_arg eq 'fast' ); ## Sereal 3.008+, if available, is used automatically by MCE 1.800. if ( $_arg eq 'sereal' ) { if ( shift eq '0' ) { require Storable; $_p->{FREEZE} = \&Storable::freeze; $_p->{THAW} = \&Storable::thaw; } next; } _croak("Error: ($_argument) invalid module option"); } $_p->{MAX_WORKERS} = MCE::Util::_parse_max_workers($_p->{MAX_WORKERS}); _validate_number($_p->{MAX_WORKERS}, 'MAX_WORKERS'); _validate_number($_p->{CHUNK_SIZE}, 'CHUNK_SIZE') unless ($_p->{CHUNK_SIZE} eq 'auto'); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## The task end callback for when a task completes. ## ############################################################################### sub _task_end { my ($_mce, $_task_id, $_task_name) = @_; my $_pid = $_mce->{_init_pid}.'.'.$_mce->{_caller}; if (defined $_mce->{user_tasks}->[$_task_id + 1]) { my $n_workers = $_mce->{user_tasks}->[$_task_id + 1]->{max_workers}; $_queue->{$_pid}[$_task_id]->enqueue((undef) x $n_workers); } $_params->{task_end}->($_mce, $_task_id, $_task_name) if (exists $_params->{task_end} && ref $_params->{task_end} eq 'CODE'); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Methods for MCE; step, enq, enqp, await. ## ############################################################################### { no warnings 'redefine'; sub MCE::step { my $x = shift; my $self = ref($x) ? $x : $MCE::MCE; my $_pid = $self->{_init_pid}.'.'.$self->{_caller}; _croak('MCE::step: method is not allowed by the manager process') unless ($self->{_wid}); my $_task_id = $self->{_task_id}; if ($_task_id < $_last_task_id->{$_pid}) { if (scalar @_ > 1 || ref $_[0] || !defined $_[0]) { $_queue->{$_pid}[$_task_id]->enqueue($self->freeze([ @_ ]).'1'); } else { $_queue->{$_pid}[$_task_id]->enqueue($_[0].'0'); } } else { _croak('MCE::step: method is not allowed by the last task'); } return; } ############################################################################ sub MCE::enq { my $x = shift; my $self = ref($x) ? $x : $MCE::MCE; my $_pid = $self->{_init_pid}.'.'.$self->{_caller}; my $_name = shift; _croak('MCE::enq: method is not allowed by the manager process') unless ($self->{_wid}); _croak('MCE::enq: (task_name) is not specified or valid') if (!defined $_name || !exists $_lkup->{$_pid}{$_name}); _croak('MCE::enq: stepping to same task or backwards is not allowed') if ($_lkup->{$_pid}{$_name} <= $self->{_task_id}); my $_task_id = $_lkup->{$_pid}{$_name} - 1; if ($_task_id < $_last_task_id->{$_pid}) { if (scalar @_ > 1) { my @_items = map { (ref $_ || !defined $_) ? $self->freeze([ $_ ]).'1' : $_.'0'; } @_; $_queue->{$_pid}[$_task_id]->enqueue(@_items); } elsif (!defined $_[0] || ref $_[0]) { $_queue->{$_pid}[$_task_id]->enqueue($self->freeze([ @_ ]).'1'); } else { $_queue->{$_pid}[$_task_id]->enqueue($_[0].'0'); } } else { _croak('MCE::enq: method is not allowed by the last task'); } return; } ############################################################################ sub MCE::enqp { my $x = shift; my $self = ref($x) ? $x : $MCE::MCE; my $_pid = $self->{_init_pid}.'.'.$self->{_caller}; my ($_name, $_p) = (shift, shift); _croak('MCE::enqp: method is not allowed by the manager process') unless ($self->{_wid}); _croak('MCE::enqp: (task_name) is not specified or valid') if (!defined $_name || !exists $_lkup->{$_pid}{$_name}); _croak('MCE::enqp: stepping to same task or backwards is not allowed') if ($_lkup->{$_pid}{$_name} <= $self->{_task_id}); _croak('MCE::enqp: (priority) is not an integer') if (!looks_like_number($_p) || int($_p) != $_p); my $_task_id = $_lkup->{$_pid}{$_name} - 1; if ($_task_id < $_last_task_id->{$_pid}) { if (scalar @_ > 1) { my @_items = map { (ref $_ || !defined $_) ? $self->freeze([ $_ ]).'1' : $_.'0'; } @_; $_queue->{$_pid}[$_task_id]->enqueuep($_p, @_items); } elsif (!defined $_[0] || ref $_[0]) { $_queue->{$_pid}[$_task_id]->enqueuep($_p, $self->freeze([ @_ ]).'1'); } else { $_queue->{$_pid}[$_task_id]->enqueuep($_p, $_[0].'0'); } } else { _croak('MCE::enqp: method is not allowed by the last task'); } return; } ############################################################################ sub MCE::await { my $x = shift; my $self = ref($x) ? $x : $MCE::MCE; my $_pid = $self->{_init_pid}.'.'.$self->{_caller}; my $_name = shift; _croak('MCE::await: method is not allowed by the manager process') unless ($self->{_wid}); _croak('MCE::await: (task_name) is not specified or valid') if (!defined $_name || !exists $_lkup->{$_pid}{$_name}); _croak('MCE::await: awaiting from same task or backwards is not allowed') if ($_lkup->{$_pid}{$_name} <= $self->{_task_id}); my $_task_id = $_lkup->{$_pid}{$_name} - 1; my $_t = shift || 0; _croak('MCE::await: (threshold) is not an integer') if (!looks_like_number($_t) || int($_t) != $_t); if ($_task_id < $_last_task_id->{$_pid}) { $_queue->{$_pid}[$_task_id]->await($_t); } else { _croak('MCE::await: method is not allowed by the last task'); } return; } } ############################################################################### ## ---------------------------------------------------------------------------- ## Init and finish routines. ## ############################################################################### sub init (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Step'); my $_pkg = "$$.$_tid.".caller(); $_params->{$_pkg} = (ref $_[0] eq 'HASH') ? shift : { @_ }; @_ = (); return; } sub finish (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Step'); my $_pkg = (defined $_[0]) ? shift : "$$.$_tid.".caller(); if ( $_pkg eq 'MCE' ) { for my $_k ( keys %{ $_MCE } ) { MCE::Step->finish($_k, 1); } } elsif ( $_MCE->{$_pkg} && $_MCE->{$_pkg}{_init_pid} eq "$$.$_tid" ) { $_MCE->{$_pkg}->shutdown(@_) if $_MCE->{$_pkg}{_spawned}; delete $_lkup->{$_pkg}; delete $_last_task_id->{$_pkg}; delete $_user_tasks->{$_pkg}; delete $_prev_c->{$_pkg}; delete $_prev_n->{$_pkg}; delete $_prev_t->{$_pkg}; delete $_prev_w->{$_pkg}; delete $_MCE->{$_pkg}; if (defined $_queue->{$_pkg}) { local $_; $_->DESTROY() for (@{ $_queue->{$_pkg} }); delete $_queue->{$_pkg}; } } @_ = (); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Parallel step with MCE -- file. ## ############################################################################### sub run_file (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Step'); my ($_file, $_pos); my $_start_pos = (ref $_[0] eq 'HASH') ? 2 : 1; my $_pid = "$$.$_tid.".caller(); if (defined (my $_p = $_params->{$_pid})) { delete $_p->{input_data} if (exists $_p->{input_data}); delete $_p->{sequence} if (exists $_p->{sequence}); } else { $_params->{$_pid} = {}; } for my $_i ($_start_pos .. @_ - 1) { my $_r = ref $_[$_i]; if ($_r eq '' || $_r eq 'SCALAR' || $_r =~ /^(?:GLOB|FileHandle|IO::)/) { $_file = $_[$_i]; $_pos = $_i; last; } } if (defined $_file && ref $_file eq '' && $_file ne '') { _croak("$_tag: ($_file) does not exist") unless (-e $_file); _croak("$_tag: ($_file) is not readable") unless (-r $_file); _croak("$_tag: ($_file) is not a plain file") unless (-f $_file); $_params->{$_pid}{_file} = $_file; } elsif (ref $_file eq 'SCALAR' || ref($_file) =~ /^(?:GLOB|FileHandle|IO::)/) { $_params->{$_pid}{_file} = $_file; } else { _croak("$_tag: (file) is not specified or valid"); } if (defined $_pos) { pop @_ for ($_pos .. @_ - 1); } return run(@_); } ############################################################################### ## ---------------------------------------------------------------------------- ## Parallel step with MCE -- sequence. ## ############################################################################### sub run_seq (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Step'); my ($_begin, $_end, $_pos); my $_start_pos = (ref $_[0] eq 'HASH') ? 2 : 1; my $_pid = "$$.$_tid.".caller(); if (defined (my $_p = $_params->{$_pid})) { delete $_p->{sequence} if (exists $_p->{sequence}); delete $_p->{input_data} if (exists $_p->{input_data}); delete $_p->{_file} if (exists $_p->{_file}); } else { $_params->{$_pid} = {}; } for my $_i ($_start_pos .. @_ - 1) { my $_ref = ref $_[$_i]; if ($_ref eq '' || $_ref eq 'HASH' || $_ref eq 'ARRAY') { $_pos = $_i; if ($_ref eq '') { $_begin = $_[$_pos]; $_end = $_[$_pos + 1]; $_params->{$_pid}{sequence} = [ $_[$_pos], $_[$_pos + 1], $_[$_pos + 2], $_[$_pos + 3] ]; } elsif ($_ref eq 'HASH') { $_begin = $_[$_pos]->{begin}; $_end = $_[$_pos]->{end}; $_params->{$_pid}{sequence} = $_[$_pos]; } elsif ($_ref eq 'ARRAY') { $_begin = $_[$_pos]->[0]; $_end = $_[$_pos]->[1]; $_params->{$_pid}{sequence} = $_[$_pos]; } last; } } _croak("$_tag: (sequence) is not specified or valid") unless (exists $_params->{$_pid}{sequence}); _croak("$_tag: (begin) is not specified for sequence") unless (defined $_begin); _croak("$_tag: (end) is not specified for sequence") unless (defined $_end); $_params->{$_pid}{sequence_run} = 1; if (defined $_pos) { pop @_ for ($_pos .. @_ - 1); } return run(@_); } ############################################################################### ## ---------------------------------------------------------------------------- ## Parallel step with MCE. ## ############################################################################### sub run (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Step'); my $_pkg = caller() eq 'MCE::Step' ? caller(1) : caller(); my $_pid = "$$.$_tid.$_pkg"; if (ref $_[0] eq 'HASH') { $_params->{$_pid} = {} unless defined $_params->{$_pid}; for my $_p (keys %{ $_[0] }) { $_params->{$_pid}{$_p} = $_[0]->{$_p}; } shift; } ## ------------------------------------------------------------------------- my (@_code, @_name, @_thrs, @_wrks); my $_init_mce = 0; my $_pos = 0; %{ $_lkup->{$_pid} } = (); while (ref $_[0] eq 'CODE') { push @_code, $_[0]; if (defined (my $_p = $_params->{$_pid})) { push @_name, (ref $_p->{task_name} eq 'ARRAY') ? $_p->{task_name}->[$_pos] : undef; push @_thrs, (ref $_p->{use_threads} eq 'ARRAY') ? $_p->{use_threads}->[$_pos] : undef; push @_wrks, (ref $_p->{max_workers} eq 'ARRAY') ? $_p->{max_workers}->[$_pos] : undef; } $_lkup->{$_pid}{ $_name[ $_pos ] } = $_pos if (defined $_name[ $_pos ]); $_init_mce = 1 if ( !defined $_prev_c->{$_pid}[$_pos] || $_prev_c->{$_pid}[$_pos] != $_code[$_pos] ); $_init_mce = 1 if ($_prev_n->{$_pid}[$_pos] ne $_name[$_pos]); $_init_mce = 1 if ($_prev_t->{$_pid}[$_pos] ne $_thrs[$_pos]); $_init_mce = 1 if ($_prev_w->{$_pid}[$_pos] ne $_wrks[$_pos]); $_prev_c->{$_pid}[$_pos] = $_code[$_pos]; $_prev_n->{$_pid}[$_pos] = $_name[$_pos]; $_prev_t->{$_pid}[$_pos] = $_thrs[$_pos]; $_prev_w->{$_pid}[$_pos] = $_wrks[$_pos]; shift; $_pos++; } if (defined $_prev_c->{$_pid}[$_pos]) { pop @{ $_prev_c->{$_pid} } for ($_pos .. $#{ $_prev_c->{$_pid } }); pop @{ $_prev_n->{$_pid} } for ($_pos .. $#{ $_prev_n->{$_pid } }); pop @{ $_prev_t->{$_pid} } for ($_pos .. $#{ $_prev_t->{$_pid } }); pop @{ $_prev_w->{$_pid} } for ($_pos .. $#{ $_prev_w->{$_pid } }); $_init_mce = 1; } return unless (scalar @_code); ## ------------------------------------------------------------------------- my $_input_data; my $_max_workers = $_def->{$_pkg}{MAX_WORKERS}; my $_r = ref $_[0]; if ($_r eq 'ARRAY' || $_r eq 'SCALAR' || $_r =~ /^(?:GLOB|FileHandle|IO::)/) { $_input_data = shift if (@_ == 1); } if (defined (my $_p = $_params->{$_pid})) { $_max_workers = MCE::Util::_parse_max_workers($_p->{max_workers}) if (exists $_p->{max_workers} && ref $_p->{max_workers} ne 'ARRAY'); delete $_p->{sequence} if (defined $_input_data || scalar @_); delete $_p->{user_func} if (exists $_p->{user_func}); delete $_p->{user_tasks} if (exists $_p->{user_tasks}); } if (@_code > 1 && $_max_workers > 1) { $_max_workers = int($_max_workers / @_code + 0.5) + 1; } my $_chunk_size = MCE::Util::_parse_chunk_size( $_def->{$_pkg}{CHUNK_SIZE}, $_max_workers, $_params->{$_pid}, $_input_data, scalar @_ ); if (defined (my $_p = $_params->{$_pid})) { if (exists $_p->{_file}) { $_input_data = delete $_p->{_file}; } else { $_input_data = $_p->{input_data} if exists $_p->{input_data}; } } ## ------------------------------------------------------------------------- MCE::_save_state(); if ($_init_mce) { $_MCE->{$_pid}->shutdown() if (defined $_MCE->{$_pid}); $_queue->{$_pid} = [] if (!defined $_queue->{$_pid}); my $_Q = $_queue->{$_pid}; pop(@{ $_Q })->DESTROY for (@_code .. @{ $_Q }); push @{ $_Q }, MCE::Queue->new(fast => $_def->{$_pkg}{FAST}, await => 1) for (@{ $_Q } .. @_code - 2); $_last_task_id->{$_pid} = @_code - 1; ## must clear arrays for nested session to work with Perl < v5.14 _gen_user_tasks($_pid,$_Q, [@_code],[@_name],[@_thrs],[@_wrks], $_chunk_size); @_code = @_name = @_thrs = @_wrks = (); my %_opts = ( max_workers => $_max_workers, task_name => $_tag, user_tasks => $_user_tasks->{$_pid}, task_end => \&_task_end, ); if (defined (my $_p = $_params->{$_pid})) { local $_; for (keys %{ $_p }) { next if ($_ eq 'max_workers' && ref $_p->{max_workers} eq 'ARRAY'); next if ($_ eq 'task_name' && ref $_p->{task_name} eq 'ARRAY'); next if ($_ eq 'use_threads' && ref $_p->{use_threads} eq 'ARRAY'); next if ($_ eq 'chunk_size'); next if ($_ eq 'input_data'); next if ($_ eq 'sequence_run'); next if ($_ eq 'task_end'); _croak("MCE::Step: ($_) is not a valid constructor argument") unless (exists $MCE::_valid_fields_new{$_}); $_opts{$_} = $_p->{$_}; } } for my $_k (qw/ tmp_dir freeze thaw /) { $_opts{$_k} = $_def->{$_pkg}{uc($_k)} if (exists $_def->{$_pkg}{uc($_k)} && !exists $_opts{$_k}); } $_MCE->{$_pid} = MCE->new(pkg => $_pkg, %_opts); } else { ## Workers may persist after running. Thus, updating the MCE instance. ## These options do not require respawning. if (defined (my $_p = $_params->{$_pid})) { for my $_k (qw( RS interval stderr_file stdout_file user_error user_output job_delay submit_delay on_post_exit on_post_run user_args flush_file flush_stderr flush_stdout gather max_retries )) { $_MCE->{$_pid}{$_k} = $_p->{$_k} if (exists $_p->{$_k}); } } } ## ------------------------------------------------------------------------- my @_a; my $_wa = wantarray; $_MCE->{$_pid}{gather} = \@_a if (defined $_wa); if (defined $_input_data) { @_ = (); $_MCE->{$_pid}->process({ chunk_size => $_chunk_size }, $_input_data); delete $_MCE->{$_pid}{input_data}; } elsif (scalar @_) { $_MCE->{$_pid}->process({ chunk_size => $_chunk_size }, \@_); delete $_MCE->{$_pid}{input_data}; } else { if (defined $_params->{$_pid} && exists $_params->{$_pid}{sequence}) { $_MCE->{$_pid}->run({ chunk_size => $_chunk_size, sequence => $_params->{$_pid}{sequence} }, 0); if (exists $_params->{$_pid}{sequence_run}) { delete $_params->{$_pid}{sequence_run}; delete $_params->{$_pid}{sequence}; } delete $_MCE->{$_pid}{sequence}; } else { $_MCE->{$_pid}->run({ chunk_size => $_chunk_size }, 0); } } MCE::_restore_state(); # auto-shutdown if in eval state if ($^S || $ENV{'PERL_IPERL_RUNNING'}) { if (!$INC{'Mojo/IOLoop.pm'} && !$INC{'Tk.pm'}) { $_MCE->{$_pid}->shutdown(); $_->DESTROY() for @{ $_queue->{$_pid} }; delete $_queue->{$_pid}; } } delete $_MCE->{$_pid}{gather} if (defined $_wa); return ((defined $_wa) ? @_a : ()); } ############################################################################### ## ---------------------------------------------------------------------------- ## Private methods. ## ############################################################################### sub _croak { goto &MCE::_croak; } sub _gen_user_func { my ($_qref, $_cref, $_chunk_size, $_pos) = @_; my $_q_in = $_qref->[$_pos - 1]; my $_code = $_cref->[$_pos]; return sub { my ($_mce) = @_; $_mce->{_next_jmp} = sub { goto _MCE_STEP__NEXT; }; $_mce->{_last_jmp} = sub { goto _MCE_STEP__LAST; }; _MCE_STEP__NEXT: while (defined (local $_ = $_q_in->dequeue())) { if (chop $_) { my $_args = $_mce->thaw($_); $_ = $_args->[0]; $_code->($_mce, @{ $_args }); } else { $_code->($_mce, $_); } } _MCE_STEP__LAST: return; }; } sub _gen_user_tasks { my ($_pid, $_qref, $_cref, $_nref, $_tref, $_wref, $_chunk_size) = @_; @{ $_user_tasks->{$_pid} } = (); push @{ $_user_tasks->{$_pid} }, { task_name => $_nref->[0], use_threads => $_tref->[0], max_workers => $_wref->[0], user_func => sub { $_cref->[0]->(@_); return; } }; for my $_pos (1 .. @{ $_cref } - 1) { push @{ $_user_tasks->{$_pid} }, { task_name => $_nref->[$_pos], use_threads => $_tref->[$_pos], max_workers => $_wref->[$_pos], user_func => _gen_user_func( $_qref, $_cref, $_chunk_size, $_pos ) }; } return; } sub _validate_number { my ($_n, $_key) = @_; _croak("$_tag: ($_key) is not valid") if (!defined $_n); $_n =~ s/K\z//i; $_n =~ s/M\z//i; if (!looks_like_number($_n) || int($_n) != $_n || $_n < 1) { _croak("$_tag: ($_key) is not valid"); } return; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Step - Parallel step model for building creative steps =head1 VERSION This document describes MCE::Step version 1.810 =head1 DESCRIPTION MCE::Step is similar to L for writing custom apps. The main difference comes from the transparent use of queues between sub-tasks. MCE 1.7 adds mce_enq, mce_enqp, and mce_await methods described under QUEUE-LIKE FEATURES below. It is trivial to parallelize with mce_stream shown below. ## Native map function my @a = map { $_ * 4 } map { $_ * 3 } map { $_ * 2 } 1..10000; ## Same as with MCE::Stream (processing from right to left) @a = mce_stream sub { $_ * 4 }, sub { $_ * 3 }, sub { $_ * 2 }, 1..10000; ## Pass an array reference to have writes occur simultaneously mce_stream \@a, sub { $_ * 4 }, sub { $_ * 3 }, sub { $_ * 2 }, 1..10000; However, let's have MCE::Step compute the same in parallel. Unlike the example in L, the use of MCE::Queue is totally transparent. This calls for preserving output order provided by MCE::Candy. use MCE::Step; use MCE::Candy; Next are the 3 sub-tasks. Compare these 3 sub-tasks with the same as described in L. The call to MCE->step simplifies the passing of data to subsequent sub-task. sub task_a { my @ans; my ($mce, $chunk_ref, $chunk_id) = @_; push @ans, map { $_ * 2 } @{ $chunk_ref }; MCE->step(\@ans, $chunk_id); } sub task_b { my @ans; my ($mce, $chunk_ref, $chunk_id) = @_; push @ans, map { $_ * 3 } @{ $chunk_ref }; MCE->step(\@ans, $chunk_id); } sub task_c { my @ans; my ($mce, $chunk_ref, $chunk_id) = @_; push @ans, map { $_ * 4 } @{ $chunk_ref }; MCE->gather($chunk_id, \@ans); } In summary, MCE::Step builds out a MCE instance behind the scene and starts running. The task_name (shown), max_workers, and use_threads options can take an anonymous array for specifying the values uniquely per each sub-task. The task_name option is required to use ->enq, ->enqp, and ->await. my @a; mce_step { task_name => [ 'a', 'b', 'c' ], gather => MCE::Candy::out_iter_array(\@a) }, \&task_a, \&task_b, \&task_c, 1..10000; print "@a\n"; =head1 STEP DEMO In the demonstration below, one may call ->gather or ->step any number of times although ->step is not allowed in the last sub-block. Data is gathered to @arr which may likely be out-of-order. Gathering data is optional. All sub-blocks receive $mce as the first argument. First, defining 3 sub-tasks. use MCE::Step; sub task_a { my ($mce, $chunk_ref, $chunk_id) = @_; if ($_ % 2 == 0) { MCE->gather($_); # MCE->gather($_ * 4); ## Ok to gather multiple times } else { MCE->print("a step: $_, $_ * $_\n"); MCE->step($_, $_ * $_); # MCE->step($_, $_ * 4 ); ## Ok to step multiple times } } sub task_b { my ($mce, $arg1, $arg2) = @_; MCE->print("b args: $arg1, $arg2\n"); if ($_ % 3 == 0) { ## $_ is the same as $arg1 MCE->gather($_); } else { MCE->print("b step: $_ * $_\n"); MCE->step($_ * $_); } } sub task_c { my ($mce, $arg1) = @_; MCE->print("c: $_\n"); MCE->gather($_); } Next, pass MCE options, using chunk_size 1, and run all 3 tasks in parallel. Notice how max_workers and use_threads can take an anonymous array, similarly to task_name. my @arr = mce_step { task_name => [ 'a', 'b', 'c' ], max_workers => [ 2, 2, 2 ], use_threads => [ 0, 0, 0 ], chunk_size => 1 }, \&task_a, \&task_b, \&task_c, 1..10; Finally, sort the array and display its contents. @arr = sort { $a <=> $b } @arr; print "\n@arr\n\n"; -- Output a step: 1, 1 * 1 a step: 3, 3 * 3 a step: 5, 5 * 5 a step: 7, 7 * 7 a step: 9, 9 * 9 b args: 1, 1 b step: 1 * 1 b args: 3, 9 b args: 7, 49 b step: 7 * 7 b args: 5, 25 b step: 5 * 5 b args: 9, 81 c: 1 c: 49 c: 25 1 2 3 4 6 8 9 10 25 49 =head1 SYNOPSIS when CHUNK_SIZE EQUALS 1 Although L may be preferred for running using a single code block, the text below also applies to this module, particularly for the first block. All models in MCE default to 'auto' for chunk_size. The arguments for the block are the same as writing a user_func block using the Core API. Beginning with MCE 1.5, the next input item is placed into the input scalar variable $_ when chunk_size equals 1. Otherwise, $_ points to $chunk_ref containing many items. Basically, line 2 below may be omitted from your code when using $_. One can call MCE->chunk_id to obtain the current chunk id. line 1: user_func => sub { line 2: my ($mce, $chunk_ref, $chunk_id) = @_; line 3: line 4: $_ points to $chunk_ref->[0] line 5: in MCE 1.5 when chunk_size == 1 line 6: line 7: $_ points to $chunk_ref line 8: in MCE 1.5 when chunk_size > 1 line 9: } Follow this synopsis when chunk_size equals one. Looping is not required from inside the first block. Hence, the block is called once per each item. ## Exports mce_step, mce_step_f, and mce_step_s use MCE::Step; MCE::Step::init { chunk_size => 1 }; ## Array or array_ref mce_step sub { do_work($_) }, 1..10000; mce_step sub { do_work($_) }, [ 1..10000 ]; ## File_path, glob_ref, or scalar_ref mce_step_f sub { chomp; do_work($_) }, "/path/to/file"; mce_step_f sub { chomp; do_work($_) }, $file_handle; mce_step_f sub { chomp; do_work($_) }, \$scalar; ## Sequence of numbers (begin, end [, step, format]) mce_step_s sub { do_work($_) }, 1, 10000, 5; mce_step_s sub { do_work($_) }, [ 1, 10000, 5 ]; mce_step_s sub { do_work($_) }, { begin => 1, end => 10000, step => 5, format => undef }; =head1 SYNOPSIS when CHUNK_SIZE is GREATER THAN 1 Follow this synopsis when chunk_size equals 'auto' or greater than 1. This means having to loop through the chunk from inside the first block. use MCE::Step; MCE::Step::init { ## Chunk_size defaults to 'auto' when chunk_size => 'auto' ## not specified. Therefore, the init }; ## function may be omitted. ## Syntax is shown for mce_step for demonstration purposes. ## Looping inside the block is the same for mce_step_f and ## mce_step_s. mce_step sub { do_work($_) for (@{ $_ }) }, 1..10000; ## Same as above, resembles code using the Core API. mce_step sub { my ($mce, $chunk_ref, $chunk_id) = @_; for (@{ $chunk_ref }) { do_work($_); } }, 1..10000; Chunking reduces the number of IPC calls behind the scene. Think in terms of chunks whenever processing a large amount of data. For relatively small data, choosing 1 for chunk_size is fine. =head1 OVERRIDING DEFAULTS The following list options which may be overridden when loading the module. use Sereal qw( encode_sereal decode_sereal ); use CBOR::XS qw( encode_cbor decode_cbor ); use JSON::XS qw( encode_json decode_json ); use MCE::Step max_workers => 8, # Default 'auto' chunk_size => 500, # Default 'auto' tmp_dir => "/path/to/app/tmp", # $MCE::Signal::tmp_dir freeze => \&encode_sereal, # \&Storable::freeze thaw => \&decode_sereal, # \&Storable::thaw fast => 1 # Default 0 (fast dequeue) ; From MCE 1.8 onwards, Sereal 3.008+ is loaded automatically if available. Specify C 0> to use Storable instead. use MCE::Step Sereal => 0; =head1 CUSTOMIZING MCE =over 3 =item MCE::Step->init ( options ) =item MCE::Step::init { options } The init function accepts a hash of MCE options. Unlike with MCE::Stream, both gather and bounds_only options may be specified when calling init (not shown below). use MCE::Step; MCE::Step::init { chunk_size => 1, max_workers => 4, user_begin => sub { print "## ", MCE->wid, " started\n"; }, user_end => sub { print "## ", MCE->wid, " completed\n"; } }; my %a = mce_step sub { MCE->gather($_, $_ * $_) }, 1..100; print "\n", "@a{1..100}", "\n"; -- Output ## 3 started ## 1 started ## 4 started ## 2 started ## 3 completed ## 4 completed ## 1 completed ## 2 completed 1 4 9 16 25 36 49 64 81 100 121 144 169 196 225 256 289 324 361 400 441 484 529 576 625 676 729 784 841 900 961 1024 1089 1156 1225 1296 1369 1444 1521 1600 1681 1764 1849 1936 2025 2116 2209 2304 2401 2500 2601 2704 2809 2916 3025 3136 3249 3364 3481 3600 3721 3844 3969 4096 4225 4356 4489 4624 4761 4900 5041 5184 5329 5476 5625 5776 5929 6084 6241 6400 6561 6724 6889 7056 7225 7396 7569 7744 7921 8100 8281 8464 8649 8836 9025 9216 9409 9604 9801 10000 =back Like with MCE::Step::init above, MCE options may be specified using an anonymous hash for the first argument. Notice how task_name, max_workers, and use_threads can take an anonymous array for setting uniquely per each code block. Unlike MCE::Stream which processes from right-to-left, MCE::Step begins with the first code block, thus processing from left-to-right. The following takes 9 seconds to complete. The 9 seconds is from having only 2 workers assigned for the last sub-task and waiting 1 or 2 seconds initially before calling MCE->step. Removing both calls to MCE->step will cause the script to complete in just 1 second. The reason is due to the 2nd and subsequent sub-tasks awaiting data from an internal queue. Workers terminate upon receiving an undef. use threads; use MCE::Step; my @a = mce_step { task_name => [ 'a', 'b', 'c' ], max_workers => [ 3, 4, 2, ], use_threads => [ 1, 0, 0, ], user_end => sub { my ($mce, $task_id, $task_name) = @_; MCE->print("$task_id - $task_name completed\n"); }, task_end => sub { my ($mce, $task_id, $task_name) = @_; MCE->print("$task_id - $task_name ended\n"); } }, sub { sleep 1; MCE->step(""); }, ## 3 workers, named a sub { sleep 2; MCE->step(""); }, ## 4 workers, named b sub { sleep 3; }; ## 2 workers, named c -- Output 0 - a completed 0 - a completed 0 - a completed 0 - a ended 1 - b completed 1 - b completed 1 - b completed 1 - b completed 1 - b ended 2 - c completed 2 - c completed 2 - c ended =head1 API DOCUMENTATION Although input data is optional for MCE::Step, the following assumes chunk_size equals 1 in order to demonstrate all the possibilities of passing input data into the code block. =over 3 =item MCE::Step->run ( { input_data => iterator }, sub { code } ) =item mce_step { input_data => iterator }, sub { code } An iterator reference can by specified for input_data. The only other way is to specify input_data via MCE::Step::init. This prevents MCE::Step from configuring the iterator reference as another user task which will not work. Iterators are described under "SYNTAX for INPUT_DATA" at L. MCE::Step::init { input_data => iterator }; mce_step sub { $_ }; =item MCE::Step->run ( sub { code }, list ) =item mce_step sub { code }, list Input data can be defined using a list. mce_step sub { $_ }, 1..1000; mce_step sub { $_ }, [ 1..1000 ]; =item MCE::Step->run_file ( sub { code }, file ) =item mce_step_f sub { code }, file The fastest of these is the /path/to/file. Workers communicate the next offset position among themselves without any interaction from the manager process. mce_step_f sub { $_ }, "/path/to/file"; mce_step_f sub { $_ }, $file_handle; mce_step_f sub { $_ }, \$scalar; =item MCE::Step->run_seq ( sub { code }, $beg, $end [, $step, $fmt ] ) =item mce_step_s sub { code }, $beg, $end [, $step, $fmt ] Sequence can be defined as a list, an array reference, or a hash reference. The functions require both begin and end values to run. Step and format are optional. The format is passed to sprintf (% may be omitted below). my ($beg, $end, $step, $fmt) = (10, 20, 0.1, "%4.1f"); mce_step_s sub { $_ }, $beg, $end, $step, $fmt; mce_step_s sub { $_ }, [ $beg, $end, $step, $fmt ]; mce_step_s sub { $_ }, { begin => $beg, end => $end, step => $step, format => $fmt }; The sequence engine can compute 'begin' and 'end' items only, for the chunk, and not the items in between (hence boundaries only). This option applies to sequence only and has no effect when chunk_size equals 1. The time to run is 0.006s below. This becomes 0.827s without the bounds_only option due to computing all items in between, thus creating a very large array. Basically, specify bounds_only => 1 when boundaries is all you need for looping inside the block; e.g. Monte Carlo simulations. Time was measured using 1 worker to emphasize the difference. use MCE::Step; MCE::Step::init { max_workers => 1, chunk_size => 1_250_000, bounds_only => 1 }; ## For sequence, the input scalar $_ points to $chunk_ref ## when chunk_size > 1, otherwise $chunk_ref->[0]. ## ## mce_step_s sub { ## my $begin = $_->[0]; my $end = $_->[-1]; ## ## for ($begin .. $end) { ## ... ## } ## ## }, 1, 10_000_000; mce_step_s sub { my ($mce, $chunk_ref, $chunk_id) = @_; ## $chunk_ref contains 2 items, not 1_250_000 my $begin = $chunk_ref->[ 0]; my $end = $chunk_ref->[-1]; ## or $chunk_ref->[1] MCE->printf("%7d .. %8d\n", $begin, $end); }, 1, 10_000_000; -- Output 1 .. 1250000 1250001 .. 2500000 2500001 .. 3750000 3750001 .. 5000000 5000001 .. 6250000 6250001 .. 7500000 7500001 .. 8750000 8750001 .. 10000000 =back =head1 QUEUE-LIKE FEATURES =over 3 =item MCE->step ( item ) =item MCE->step ( arg1, arg2, argN ) The ->step method is the simplest form for passing elements into the next sub-task. use MCE::Step; sub provider { MCE->step( $_, rand ) for 10 .. 19; } sub consumer { my ( $mce, @args ) = @_; MCE->printf( "%d: %d, %03.06f\n", MCE->wid, $args[0], $args[1] ); } MCE::Step::init { task_name => [ 'p', 'c' ], max_workers => [ 1 , 4 ] }; mce_step \&provider, \&consumer; -- Output 2: 10, 0.583551 4: 11, 0.175319 3: 12, 0.843662 4: 15, 0.748302 2: 14, 0.591752 3: 16, 0.357858 5: 13, 0.953528 4: 17, 0.698907 2: 18, 0.985448 3: 19, 0.146548 =item MCE->enq ( task_name, item ) =item MCE->enq ( task_name, [ arg1, arg2, argN ] ) =item MCE->enq ( task_name, [ arg1, arg2 ], [ arg1, arg2 ] ) =item MCE->enqp ( task_name, priority, item ) =item MCE->enqp ( task_name, priority, [ arg1, arg2, argN ] ) =item MCE->enqp ( task_name, priority, [ arg1, arg2 ], [ arg1, arg2 ] ) The MCE 1.7 release enables finer control. Unlike ->step, which take multiple arguments, the ->enq and ->enqp methods push items at the end of the array internally. Passing multiple arguments is possible by enclosing the arguments inside an anonymous array. The direction of flow is forward only. Thus, stepping to itself or backwards will cause an error. use MCE::Step; sub provider { if ( MCE->wid % 2 == 0 ) { MCE->enq( 'c', [ $_, rand ] ) for 10 .. 19; } else { MCE->enq( 'd', [ $_, rand ] ) for 20 .. 29; } } sub consumer_c { my ( $mce, $args ) = @_; MCE->printf( "C%d: %d, %03.06f\n", MCE->wid, $args->[0], $args->[1] ); } sub consumer_d { my ( $mce, $args ) = @_; MCE->printf( "D%d: %d, %03.06f\n", MCE->wid, $args->[0], $args->[1] ); } MCE::Step::init { task_name => [ 'p', 'c', 'd' ], max_workers => [ 2 , 3 , 3 ] }; mce_step \&provider, \&consumer_c, \&consumer_d; -- Output C4: 10, 0.527531 D6: 20, 0.420108 C5: 11, 0.839770 D8: 21, 0.386414 C3: 12, 0.834645 C4: 13, 0.191014 D6: 23, 0.924027 C5: 14, 0.899357 D8: 24, 0.706186 C4: 15, 0.083823 D7: 22, 0.479708 D6: 25, 0.073882 C3: 16, 0.207446 D8: 26, 0.560755 C5: 17, 0.198157 D7: 27, 0.324909 C4: 18, 0.147505 C5: 19, 0.318371 D6: 28, 0.220465 D8: 29, 0.630111 =item MCE->await ( task_name, pending_threshold ) Providers may sometime run faster than consumers. Thus, increasing memory consumption. MCE 1.7 adds the ->await method for pausing momentarily until the receiving sub-task reaches the minimum threshold for the number of items pending in its queue. use MCE::Step; use Time::HiRes 'sleep'; sub provider { for ( 10 .. 29 ) { # wait until 10 or less items pending MCE->await( 'c', 10 ); # forward item to a later sub-task ( 'c' comes after 'p' ) MCE->enq( 'c', [ $_, rand ] ); } } sub consumer { my ($mce, $args) = @_; MCE->printf( "%d: %d, %03.06f\n", MCE->wid, $args->[0], $args->[1] ); sleep 0.05; } MCE::Step::init { task_name => [ 'p', 'c' ], max_workers => [ 1 , 4 ] }; mce_step \&provider, \&consumer; -- Output 3: 10, 0.527307 2: 11, 0.036193 5: 12, 0.987168 4: 13, 0.998140 5: 14, 0.219526 4: 15, 0.061609 2: 16, 0.557664 3: 17, 0.658684 4: 18, 0.240932 3: 19, 0.241042 5: 20, 0.884830 2: 21, 0.902223 4: 22, 0.699223 3: 23, 0.208270 5: 24, 0.438919 2: 25, 0.268854 4: 26, 0.596425 5: 27, 0.979818 2: 28, 0.918173 3: 29, 0.358266 =back =head1 GATHERING DATA Unlike MCE::Map where gather and output order are done for you automatically, the gather method is used to have results sent back to the manager process. use MCE::Step chunk_size => 1; ## Output order is not guaranteed. my @a = mce_step sub { MCE->gather($_ * 2) }, 1..100; print "@a\n\n"; ## Outputs to a hash instead (key, value). my %h1 = mce_step sub { MCE->gather($_, $_ * 2) }, 1..100; print "@h1{1..100}\n\n"; ## This does the same thing due to chunk_id starting at one. my %h2 = mce_step sub { MCE->gather(MCE->chunk_id, $_ * 2) }, 1..100; print "@h2{1..100}\n\n"; The gather method can be called multiple times within the block unlike return which would leave the block. Therefore, think of gather as yielding results immediately to the manager process without actually leaving the block. use MCE::Step chunk_size => 1, max_workers => 3; my @hosts = qw( hosta hostb hostc hostd hoste ); my %h3 = mce_step sub { my ($output, $error, $status); my $host = $_; ## Do something with $host; $output = "Worker ". MCE->wid .": Hello from $host"; if (MCE->chunk_id % 3 == 0) { ## Simulating an error condition local $? = 1; $status = $?; $error = "Error from $host" } else { $status = 0; } ## Ensure unique keys (key, value) when gathering to ## a hash. MCE->gather("$host.out", $output); MCE->gather("$host.err", $error) if (defined $error); MCE->gather("$host.sta", $status); }, @hosts; foreach my $host (@hosts) { print $h3{"$host.out"}, "\n"; print $h3{"$host.err"}, "\n" if (exists $h3{"$host.err"}); print "Exit status: ", $h3{"$host.sta"}, "\n\n"; } -- Output Worker 3: Hello from hosta Exit status: 0 Worker 2: Hello from hostb Exit status: 0 Worker 1: Hello from hostc Error from hostc Exit status: 1 Worker 3: Hello from hostd Exit status: 0 Worker 2: Hello from hoste Exit status: 0 The following uses an anonymous array containing 3 elements when gathering data. Serialization is automatic behind the scene. my %h3 = mce_step sub { ... MCE->gather($host, [$output, $error, $status]); }, @hosts; foreach my $host (@hosts) { print $h3{$host}->[0], "\n"; print $h3{$host}->[1], "\n" if (defined $h3{$host}->[1]); print "Exit status: ", $h3{$host}->[2], "\n\n"; } Although MCE::Map comes to mind, one may want additional control when gathering data such as retaining output order. use MCE::Step; sub preserve_order { my %tmp; my $order_id = 1; my $gather_ref = $_[0]; return sub { $tmp{ (shift) } = \@_; while (1) { last unless exists $tmp{$order_id}; push @{ $gather_ref }, @{ delete $tmp{$order_id++} }; } return; }; } ## Workers persist for the most part after running. Though, not always ## the case and depends on Perl. Pass a reference to a subroutine if ## workers must persist; e.g. mce_step { ... }, \&foo, 1..100000. MCE::Step::init { chunk_size => 'auto', max_workers => 'auto' }; for (1..2) { my @m2; mce_step { gather => preserve_order(\@m2) }, sub { my @a; my ($mce, $chunk_ref, $chunk_id) = @_; ## Compute the entire chunk data at once. push @a, map { $_ * 2 } @{ $chunk_ref }; ## Afterwards, invoke the gather feature, which ## will direct the data to the callback function. MCE->gather(MCE->chunk_id, @a); }, 1..100000; print scalar @m2, "\n"; } MCE::Step::finish; All 6 models support 'auto' for chunk_size unlike the Core API. Think of the models as the basis for providing JIT for MCE. They create the instance, tune max_workers, and tune chunk_size automatically regardless of the hardware. The following does the same thing using the Core API. Workers persist after running. use MCE; sub preserve_order { ... } my $mce = MCE->new( max_workers => 'auto', chunk_size => 8000, user_func => sub { my @a; my ($mce, $chunk_ref, $chunk_id) = @_; ## Compute the entire chunk data at once. push @a, map { $_ * 2 } @{ $chunk_ref }; ## Afterwards, invoke the gather feature, which ## will direct the data to the callback function. MCE->gather(MCE->chunk_id, @a); } ); for (1..2) { my @m2; $mce->process({ gather => preserve_order(\@m2) }, [1..100000]); print scalar @m2, "\n"; } $mce->shutdown; =head1 MANUAL SHUTDOWN =over 3 =item MCE::Step->finish =item MCE::Step::finish Workers remain persistent as much as possible after running. Shutdown occurs automatically when the script terminates. Call finish when workers are no longer needed. use MCE::Step; MCE::Step::init { chunk_size => 20, max_workers => 'auto' }; mce_step sub { ... }, 1..100; MCE::Step::finish; =back =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.810/lib/MCE/Signal.pm0000644000175000017500000004164113022712417014061 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## Temporary directory creation/cleanup and signal handling. ## ############################################################################### package MCE::Signal; use strict; use warnings; no warnings qw( threads recursion uninitialized ); our $VERSION = '1.810'; ## no critic (BuiltinFunctions::ProhibitStringyEval) our ($display_die_with_localtime, $display_warn_with_localtime); our ($main_proc_id, $prog_name, $tmp_dir); my ($_is_winenv); use Carp (); BEGIN { local $@; local $SIG{__DIE__}; $main_proc_id = $$; $prog_name = $0; $prog_name =~ s{^.*[\\/]}{}g; $prog_name = 'perl' if ($prog_name eq '-e' || $prog_name eq '-'); $_is_winenv = ($^O =~ /mswin|mingw|msys|cygwin/i) ? 1 : 0; if ($^O eq 'MSWin32' && !$INC{'threads.pm'}) { eval 'use threads; use threads::shared'; } elsif ($INC{'threads.pm'} && !$INC{'threads/shared.pm'}) { eval 'use threads::shared'; } return; } use File::Path (); use Time::HiRes qw( sleep time ); use Fcntl qw( :flock ); use base qw( Exporter ); our @EXPORT_OK = qw( $tmp_dir sys_cmd stop_and_exit ); our %EXPORT_TAGS = ( all => \@EXPORT_OK, tmp_dir => [ qw( $tmp_dir ) ] ); sub _NOOP {} ############################################################################### ## ---------------------------------------------------------------------------- ## Process import, export, & module arguments. ## ############################################################################### sub _croak { $\ = undef; goto &Carp::croak } sub _usage { _croak "MCE::Signal error: ($_[0]) is not a valid option" } sub _flag { 1 } my $_is_MSWin32 = ($^O eq 'MSWin32') ? 1 : 0; my $_keep_tmp_dir = 0; my $_no_sigmsg = 0; my $_no_kill9 = 0; my $_imported; sub import { my $_class = shift; return if ($_imported++); my @_export_args = (); my $_no_setpgrp = 0; my $_setpgrp = 0; my $_use_dev_shm = 0; while (my $_arg = shift) { $_keep_tmp_dir = _flag() and next if ($_arg eq '-keep_tmp_dir'); $_no_sigmsg = _flag() and next if ($_arg eq '-no_sigmsg'); $_no_kill9 = _flag() and next if ($_arg eq '-no_kill9'); $_no_setpgrp = _flag() and next if ($_arg eq '-no_setpgrp'); $_setpgrp = _flag() and next if ($_arg eq '-setpgrp'); $_use_dev_shm = _flag() and next if ($_arg eq '-use_dev_shm'); _usage($_arg) if ($_arg =~ /^-/); push @_export_args, $_arg; } local $Exporter::ExportLevel = 1; Exporter::import($_class, @_export_args); ## Sets the current process group for the current process. setpgrp(0,0) if ($_setpgrp == 1 && !$_is_MSWin32); my ($_count, $_tmp_base_dir) = (0); if (exists $ENV{TEMP} && -d $ENV{TEMP} && -w $ENV{TEMP}) { if ( $_is_winenv ) { $_tmp_base_dir = $ENV{TEMP} . '/Perl-MCE'; mkdir $_tmp_base_dir unless (-d $_tmp_base_dir); } else { $_tmp_base_dir = $ENV{TEMP}; } } else { $_tmp_base_dir = ($_use_dev_shm && -d '/dev/shm' && -w '/dev/shm') ? '/dev/shm' : '/tmp'; } _croak("Error: MCE::Signal: ($_tmp_base_dir) is not writeable") if (! exists $ENV{'MOBASTARTUPDIR'} && ! -w $_tmp_base_dir); ## Remove tainted'ness from $tmp_dir. ($tmp_dir) = "$_tmp_base_dir/$prog_name.$$.$_count" =~ /(.*)/; while ( !(mkdir $tmp_dir, 0770) ) { ($tmp_dir) = ("$_tmp_base_dir/$prog_name.$$.".(++$_count)) =~ /(.*)/; } return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Configure signal handling. ## ############################################################################### ## Set traps to catch signals. $SIG{XCPU} = \&stop_and_exit if (exists $SIG{XCPU}); ## UNIX SIG 24 $SIG{XFSZ} = \&stop_and_exit if (exists $SIG{XFSZ}); ## UNIX SIG 25 $SIG{HUP} = \&stop_and_exit; ## UNIX SIG 1 $SIG{INT} = \&stop_and_exit; ## UNIX SIG 2 $SIG{PIPE} = \&stop_and_exit; ## UNIX SIG 13 $SIG{QUIT} = \&stop_and_exit; ## UNIX SIG 3 $SIG{TERM} = \&stop_and_exit; ## UNIX SIG 15 ## MCE handles the reaping of its children. $SIG{CHLD} = 'DEFAULT' unless $_is_MSWin32; ## Call stop_and_exit when exiting the script. END { MCE::Signal->stop_and_exit($?) if ($$ == $main_proc_id); } ############################################################################### ## ---------------------------------------------------------------------------- ## Run command via the system(...) function. ## ## The system function in Perl ignores SIGINT and SIGQUIT. These 2 signals ## are sent to the command being executed via system() but not back to ## the underlying Perl script. The code below will ensure the Perl script ## receives the same signal in order to raise an exception immediately ## after the system call. ## ## Returns the actual exit status. ## ############################################################################### sub sys_cmd { shift @_ if (defined $_[0] && $_[0] eq 'MCE::Signal'); _croak('MCE::Signal::sys_cmd: no arguments were specified') if (@_ == 0); my $_status = system(@_); my $_sig_no = $_status & 127; my $_exit_status = $_status >> 8; ## Kill the process group if command caught SIGINT or SIGQUIT. CORE::kill('INT', $main_proc_id, $_is_MSWin32 ? -$$ : -getpgrp) if $_sig_no == 2; CORE::kill('QUIT', $main_proc_id, $_is_MSWin32 ? -$$ : -getpgrp) if $_sig_no == 3; return $_exit_status; } ############################################################################### ## ---------------------------------------------------------------------------- ## Stops execution, removes temp directory and exits cleanly. ## ## Provides safe reentrant logic for both parent and child processes. ## The $main_proc_id variable is defined above. ## ############################################################################### my %_sig_name_lkup = map { $_ => 1 } qw( __DIE__ __WARN__ HUP INT PIPE QUIT TERM CHLD XCPU XFSZ ); my $_handler_cnt : shared = 0; sub stop_and_exit { shift @_ if (defined $_[0] && $_[0] eq 'MCE::Signal'); my $_is_main_proc = ($$ == $main_proc_id); my $_sig_name = $_[0] || 0; my $_exit_status = $?; my $_is_sig = 0; if (exists $_sig_name_lkup{$_sig_name}) { $_exit_status = $MCE::Signal::KILLED = $_is_sig = 1; $SIG{$_sig_name} = \&_NOOP; } else { $_exit_status = $_sig_name if ($_sig_name =~ /^\d+$/); } $SIG{INT} = $SIG{__DIE__} = $SIG{__WARN__} = \&_NOOP; ## ------------------------------------------------------------------------- ## For the main process. if ($_is_main_proc) { lock $_handler_cnt if $INC{'threads/shared.pm'}; if (++$_handler_cnt == 1) { open my $_FH, '>>', "$tmp_dir/stopped"; close $_FH; local $\ = undef; ## Display message and kill process group if signaled. if ($_is_sig == 1) { my $_err_msg = undef; if ($_sig_name eq 'XCPU') { $_err_msg = 'exceeded CPU time limit, exiting'; $_sig_name = 'INT'; } elsif ($_sig_name eq 'XFSZ') { $_err_msg = 'exceeded file size limit, exiting'; $_sig_name = 'INT'; } elsif ($_sig_name eq 'INT' && -f "$tmp_dir/died") { $_err_msg = 'caught signal (__DIE__), exiting'; } elsif ($_sig_name eq '__DIE__') { $_err_msg = 'caught signal (__DIE__), exiting'; $_sig_name = 'INT'; } elsif ($_sig_name ne 'PIPE') { $_err_msg = "caught signal ($_sig_name), exiting"; } if ($_err_msg && $_no_sigmsg == 0) { print {*STDERR} "\n## $prog_name: $_err_msg\n"; } open my $_FH, '>', "$tmp_dir/killed"; close $_FH; CORE::kill($_sig_name, $_is_MSWin32 ? -$$ : -getpgrp); ## Pause a bit. if ($_sig_name eq 'PIPE') { sleep 0.015 for (1..2); } else { sleep 0.060 for (1..3); } } ## Remove temp directory. if (defined $tmp_dir && $tmp_dir ne '' && -d $tmp_dir) { if ($_keep_tmp_dir == 1) { print {*STDERR} "$prog_name: saved tmp_dir = $tmp_dir\n"; } elsif ($tmp_dir ne '/tmp' && $tmp_dir ne '/var/tmp') { chdir $ENV{'TEMP'} if ($_is_winenv && $ENV{'TEMP'}); eval q{ File::Path::rmtree($tmp_dir) }; } $tmp_dir = undef; } ## Signal process group to die. if ($_is_sig == 1) { if ($_sig_name eq 'PIPE' && $INC{'MCE/Hobo.pm'}) { CORE::kill('QUIT', $_is_MSWin32 ? -$$ : -getpgrp); } if ($_sig_name ne 'PIPE' && $_no_sigmsg == 0) { print {*STDERR} "\n"; } ($_no_kill9 == 1 || $_sig_name eq 'PIPE') ? CORE::kill('INT', $_is_MSWin32 ? -$$ : -getpgrp) : CORE::kill('KILL', -$$, $main_proc_id); } } } ## Otherwise, for child processes. elsif ($_is_sig == 1 && $tmp_dir && -d $tmp_dir) { lock $_handler_cnt if $INC{'threads/shared.pm'}; if (++$_handler_cnt == 1) { if ($^O eq 'MSWin32') { if ($_keep_tmp_dir == 1) { print {*STDERR} "$prog_name: saved tmp_dir = $tmp_dir\n"; } elsif ($tmp_dir ne '/tmp' && $tmp_dir ne '/var/tmp') { chdir $ENV{'TEMP'} if ($_is_winenv && $ENV{'TEMP'}); eval q{ File::Path::rmtree($tmp_dir) }; } $tmp_dir = undef; CORE::kill('KILL', $main_proc_id, -$$); } else { ## Obtain lock. open my $CHILD_LOCK, '+>>', "$tmp_dir/child.lock"; flock $CHILD_LOCK, LOCK_EX; ## Notify the main process that I've died. if ($_sig_name eq '__DIE__' && ! -f "$tmp_dir/died") { local $@; eval { open my $_FH, '>>', "$tmp_dir/died"; close $_FH; }; } ## Signal process group to terminate. if (! -f "$tmp_dir/killed" && ! -f "$tmp_dir/stopped") { local $@; eval { open my $_FH, '>>', "$tmp_dir/killed"; close $_FH; }; ($_sig_name eq 'PIPE') ? CORE::kill('PIPE', $main_proc_id, -$$) : CORE::kill('INT', $main_proc_id, -$$); } ## Release lock. flock $CHILD_LOCK, LOCK_UN; close $CHILD_LOCK; } } } ## ------------------------------------------------------------------------- ## Exit with status. if ($_is_sig == 1 && $_no_kill9 == 0) { sleep 0.060 for (1..5); } CORE::exit($_exit_status); } ############################################################################### ## ---------------------------------------------------------------------------- ## Signal handlers for __DIE__ & __WARN__ utilized by MCE. ## ############################################################################### sub _die_handler { shift @_ if (defined $_[0] && $_[0] eq 'MCE::Signal'); if (!defined $^S || $^S) { if ( ($INC{'threads.pm'} && threads->tid() != 0) || $ENV{'PERL_IPERL_RUNNING'} ) { # thread env or running inside IPerl, check stack trace my $_t = Carp::longmess(); $_t =~ s/\teval [^\n]+\n$//; if ( $_t =~ /^(?:[^\n]+\n){1,7}\teval / || $_t =~ /\n\teval [^\n]+\n\t(?:eval|Try)/ ) { CORE::die(@_); } } else { # normal env, trust $^S CORE::die(@_); } } local $\ = undef; ## Set $MCE::Signal::display_die_with_localtime = 1; ## when wanting the output to contain the localtime. if (defined $_[0]) { if ($MCE::Signal::display_die_with_localtime) { my $_time_stamp = localtime; print {*STDERR} "## $_time_stamp: $prog_name: ERROR:\n", $_[0]; } else { print {*STDERR} $_[0]; } } MCE::Signal->stop_and_exit('__DIE__'); } sub _warn_handler { shift @_ if (defined $_[0] && $_[0] eq 'MCE::Signal'); ## Ignore thread warnings during exiting. return if ( $_[0] =~ /^A thread exited while \d+ threads were running/ || $_[0] =~ /^Attempt to free unreferenced scalar/ || $_[0] =~ /^Perl exited with active threads/ || $_[0] =~ /^Thread \d+ terminated abnormally/ ); local $\ = undef; ## Set $MCE::Signal::display_warn_with_localtime = 1; ## when wanting the output to contain the localtime. if (defined $_[0]) { if ($MCE::Signal::display_warn_with_localtime) { my $_time_stamp = localtime; print {*STDERR} "## $_time_stamp: $prog_name: WARNING:\n", $_[0]; } else { print {*STDERR} $_[0]; } } return; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Signal - Temporary directory creation/cleanup and signal handling =head1 VERSION This document describes MCE::Signal version 1.810 =head1 SYNOPSIS ## Creates tmp_dir under $ENV{TEMP} if defined, otherwise /tmp. use MCE::Signal; ## Attempts to create tmp_dir under /dev/shm if writable. use MCE::Signal qw( -use_dev_shm ); ## Keeps tmp_dir after the script terminates. use MCE::Signal qw( -keep_tmp_dir ); use MCE::Signal qw( -use_dev_shm -keep_tmp_dir ); ## MCE loads MCE::Signal by default when not present. ## Therefore, load MCE::Signal first for options to take effect. use MCE::Signal qw( -keep_tmp_dir -use_dev_shm ); use MCE; =head1 DESCRIPTION This package configures $SIG{HUP,INT,PIPE,QUIT,TERM,XCPU,XFSZ} to point to stop_and_exit and creates a temporary directory. The main process and workers receiving said signals call stop_and_exit, which signals all workers to terminate, removes the temporary directory unless -keep_tmp_dir is specified, and terminates itself. The location of the temp directory resides under $ENV{TEMP} if defined, otherwise /dev/shm if writeable and -use_dev_shm is specified, or /tmp. On Windows, the temp directory is made under $ENV{TEMP}/Perl-MCE/. As of MCE 1.405, MCE::Signal no longer calls setpgrp by default. Pass the -setpgrp option to MCE::Signal to call setpgrp. ## Running MCE through Daemon::Control requires setpgrp to be called ## for MCE releases 1.511 and below. use MCE::Signal qw(-setpgrp); ## Not necessary for MCE 1.512 and above use MCE; The following are available options and their meanings. -keep_tmp_dir - The temporary directory is not removed during exiting A message is displayed with the location afterwards -use_dev_shm - Create the temporary directory under /dev/shm -no_sigmsg - Do not display a message when receiving a signal -no_kill9 - Do not kill -9 after receiving a signal to terminate -setpgrp - Calls setpgrp to set the process group for the process This option ensures all workers terminate when reading STDIN for MCE releases 1.511 and below. cat big_input_file | ./mce_script.pl | head -10 This works fine without the -setpgrp option: ./mce_script.pl < big_input_file | head -10 Nothing is exported by default. Exportable are 1 variable and 2 subroutines. use MCE::Signal qw( $tmp_dir stop_and_exit sys_cmd ); use MCE::Signal qw( :all ); $tmp_dir - Path to the temporary directory. stop_and_exit - Described below sys_cmd - Described below =head2 stop_and_exit ( [ $exit_status | $signal ] ) Stops execution, removes temp directory, and exits the entire application. Pass 'INT' to terminate a spawned or running MCE session. MCE::Signal::stop_and_exit(1); MCE::Signal::stop_and_exit('INT'); =head2 sys_cmd ( $command ) The system function in Perl ignores SIGINT and SIGQUIT. These 2 signals are sent to the command being executed via system() but not back to the underlying Perl script. For this reason, sys_cmd was added to MCE::Signal. ## Execute command and return the actual exit status. The perl script ## is also signaled if command caught SIGINT or SIGQUIT. use MCE::Signal qw(sys_cmd); ## Include before MCE use MCE; my $exit_status = sys_cmd($command); =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.810/lib/MCE/Candy.pm0000644000175000017500000003010613022712347013676 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## Sugar methods and output iterators. ## ############################################################################### package MCE::Candy; use strict; use warnings; no warnings qw( threads recursion uninitialized ); our $VERSION = '1.810'; our @CARP_NOT = qw( MCE ); ############################################################################### ## ---------------------------------------------------------------------------- ## Import routine. ## ############################################################################### my $_imported; sub import { my $_class = shift; return if ($_imported++); unless (defined $MCE::VERSION) { $\ = undef; require Carp; Carp::croak( "MCE::Candy requires MCE. Please see the MCE::Candy documentation\n". "for more information.\n\n" ); } return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Forchunk, foreach, and forseq sugar methods. ## ############################################################################### sub forchunk { my $x = shift; my $self = ref($x) ? $x : $MCE::MCE; my $_input_data = $_[0]; MCE::_validate_runstate($self, 'MCE::forchunk'); my ($_user_func, $_params_ref); if (ref $_[1] eq 'HASH') { $_user_func = $_[2]; $_params_ref = $_[1]; } else { $_user_func = $_[1]; $_params_ref = {}; } @_ = (); MCE::_croak('MCE::forchunk: (input_data) is not specified') unless (defined $_input_data); MCE::_croak('MCE::forchunk: (code_block) is not specified') unless (defined $_user_func); $_params_ref->{input_data} = $_input_data; $_params_ref->{user_func} = $_user_func; $self->run(1, $_params_ref); return $self; } sub foreach { my $x = shift; my $self = ref($x) ? $x : $MCE::MCE; my $_input_data = $_[0]; MCE::_validate_runstate($self, 'MCE::foreach'); my ($_user_func, $_params_ref); if (ref $_[1] eq 'HASH') { $_user_func = $_[2]; $_params_ref = $_[1]; } else { $_user_func = $_[1]; $_params_ref = {}; } @_ = (); MCE::_croak('MCE::foreach: (input_data) is not specified') unless (defined $_input_data); MCE::_croak('MCE::foreach: (code_block) is not specified') unless (defined $_user_func); $_params_ref->{chunk_size} = 1; $_params_ref->{input_data} = $_input_data; $_params_ref->{user_func} = $_user_func; $self->run(1, $_params_ref); return $self; } sub forseq { my $x = shift; my $self = ref($x) ? $x : $MCE::MCE; my $_sequence = $_[0]; MCE::_validate_runstate($self, 'MCE::forseq'); my ($_user_func, $_params_ref); if (ref $_[1] eq 'HASH') { $_user_func = $_[2]; $_params_ref = $_[1]; } else { $_user_func = $_[1]; $_params_ref = {}; } @_ = (); MCE::_croak('MCE::forseq: (sequence) is not specified') unless (defined $_sequence); MCE::_croak('MCE::forseq: (code_block) is not specified') unless (defined $_user_func); $_params_ref->{sequence} = $_sequence; $_params_ref->{user_func} = $_user_func; $self->run(1, $_params_ref); return $self; } ############################################################################### ## ---------------------------------------------------------------------------- ## Output iterators for preserving output order. ## ############################################################################### sub out_iter_array { my $_aref = shift; my %_tmp; my $_order_id = 1; MCE::_croak('The argument to (out_iter_array) is not an array ref.') unless (ref($_aref) eq 'ARRAY'); return sub { my $_chunk_id = shift; if ($_chunk_id == $_order_id && keys %_tmp == 0) { ## already orderly $_order_id++; push @{ $_aref }, @_; } else { ## hold temporarily otherwise until orderly @{ $_tmp{ $_chunk_id } } = @_; while (1) { last unless exists $_tmp{ $_order_id }; push @{ $_aref }, @{ delete $_tmp{ $_order_id++ } }; } } }; } sub out_iter_fh { my $_fh = $_[0]; my %_tmp; my $_order_id = 1; $_fh = \$_[0] if (!ref $_fh && ref \$_[0]); MCE::_croak('The argument to (out_iter_fh) is not a supported file handle.') unless (ref($_fh) =~ /^(?:GLOB|FileHandle|IO::)/); return sub { my $_chunk_id = shift; if ($_chunk_id == $_order_id && keys %_tmp == 0) { ## already orderly $_order_id++; print {$_fh} @_; } else { ## hold temporarily otherwise until orderly @{ $_tmp{ $_chunk_id } } = @_; while (1) { last unless exists $_tmp{ $_order_id }; print {$_fh} @{ delete $_tmp{ $_order_id++ } }; } } }; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Candy - Sugar methods and output iterators =head1 VERSION This document describes MCE::Candy version 1.810 =head1 DESCRIPTION This module provides a collection of sugar methods and helpful output iterators for preserving output order. =head1 "FOR" SUGAR METHODS The sugar methods described below were created prior to the 1.5 release which added MCE Models. This module is loaded automatically upon calling a "for" method. =head2 $mce->forchunk ( $input_data [, { options } ], sub { ... } ) Forchunk, foreach, and forseq are sugar methods in MCE. Workers are spawned automatically, the code block is executed in parallel, and shutdown is called. Do not call these methods if workers must persist afterwards. Specifying options is optional. Valid options are the same as for the process method. ## Declare a MCE instance. my $mce = MCE->new( chunk_size => 20, max_workers => $max_workers ); ## Arguments inside the code block are the same as passed to user_func. $mce->forchunk(\@input_data, sub { my ($mce, $chunk_ref, $chunk_id) = @_; foreach ( @{ $chunk_ref } ) { MCE->print("$chunk_id: $_\n"); } }); ## Passing chunk_size as an option. $mce->forchunk(\@input_data, { chunk_size => 30 }, sub { ... }); =head2 $mce->foreach ( $input_data [, { options } ], sub { ... } ) Foreach implies chunk_size => 1 and cannot be overwritten. Thus, looping is not necessary inside the block. my $mce = MCE->new( max_workers => $max_workers ); $mce->foreach(\@input_data, sub { my ($mce, $chunk_ref, $chunk_id) = @_; my $row = $chunk_ref->[0]; MCE->print("$chunk_id: $row\n"); }); =head2 $mce->forseq ( $sequence_spec [, { options } ], sub { ... } ) Sequence can be defined using an array or hash reference. my $mce = MCE->new( max_workers => 3 ); $mce->forseq([ 20, 40 ], sub { my ($mce, $n, $chunk_id) = @_; my $result = `ping 192.168.1.${n}`; ... }); $mce->forseq({ begin => 15, end => 10, step => -1 }, sub { my ($mce, $n, $chunk_id) = @_; print $n, " from ", MCE->wid, "\n"; }); The $n_seq variable points to an array_ref of sequences. Chunk size defaults to 1 when not specified. $mce->forseq([ 20, 80 ], { chunk_size => 10 }, sub { my ($mce, $n_seq, $chunk_id) = @_; for my $n ( @{ $n_seq } ) { my $result = `ping 192.168.1.${n}`; ... } }); =head1 OUTPUT ITERATORS WITH INPUT This module includes 2 output iterators which are useful for preserving output order while gathering data. These cover the 2 general use cases. The chunk_id value must be the first argument to gather. Gather must also not be called more than once inside the block. =head2 gather => MCE::Candy::out_iter_array( \@array ) The example utilizes the Core API with chunking disabled. Basically, setting chunk_size to 1. use MCE; use MCE::Candy; my @results; my $mce = MCE->new( chunk_size => 1, max_workers => 4, gather => MCE::Candy::out_iter_array(\@results), user_func => sub { my ($mce, $chunk_ref, $chunk_id) = @_; $mce->gather($chunk_id, $chunk_ref->[0] * 2); } ); $mce->process([ 100 .. 109 ]); print "@results", "\n"; -- Output 200 202 204 206 208 210 212 214 216 218 Chunking may be desired for thousands or more items. In other words, wanting to reduce the overhead placed on IPC. use MCE; use MCE::Candy; my @results; my $mce = MCE->new( chunk_size => 100, max_workers => 4, gather => MCE::Candy::out_iter_array(\@results), user_func => sub { my ($mce, $chunk_ref, $chunk_id) = @_; my @output; foreach my $item (@{ $chunk_ref }) { push @output, $item * 2; } $mce->gather($chunk_id, @output); } ); $mce->process([ 100_000 .. 200_000 - 1 ]); print scalar @results, "\n"; -- Output 100000 =head2 gather => MCE::Candy::out_iter_fh( $fh ) Let's change things a bit and use MCE::Flow for the next 2 examples. Chunking is not desired for the first example. use MCE::Flow; use MCE::Candy; open my $fh, '>', '/tmp/foo.txt'; mce_flow { chunk_size => 1, max_workers => 4, gather => MCE::Candy::out_iter_fh($fh) }, sub { my ($mce, $chunk_ref, $chunk_id) = @_; $mce->gather($chunk_id, $chunk_ref->[0] * 2, "\n"); }, (100 .. 109); close $fh; -- Output sent to '/tmp/foo.txt' 200 202 204 206 208 210 212 214 216 218 Chunking is desired for the next example due to processing many thousands. use MCE::Flow; use MCE::Candy; open my $fh, '>', '/tmp/foo.txt'; mce_flow { chunk_size => 100, max_workers => 4, gather => MCE::Candy::out_iter_fh( $fh ) }, sub { my ($mce, $chunk_ref, $chunk_id) = @_; my @output; foreach my $item (@{ $chunk_ref }) { push @output, ($item * 2) . "\n"; } $mce->gather($chunk_id, @output); }, (100_000 .. 200_000 - 1); close $fh; print -s '/tmp/foo.txt', "\n"; -- Output 700000 =head1 OUTPUT ITERATORS WITHOUT INPUT Input data is not a requirement for using the output iterators included in this module. The 'chunk_id' value is set uniquely and the same as 'wid' when not processing input data. =head2 gather => MCE::Candy::out_iter_array( \@array ) use MCE::Flow; use MCE::Candy; my @results; mce_flow { max_workers => 'auto', ## Note that 'auto' is never higher than 8 gather => MCE::Candy::out_iter_array(\@results) }, sub { my ($mce) = @_; ## This line is not necessary ## Calling via module okay; e.g: MCE->method ## Do work ## Sending a complex data structure is allowed ## Output will become orderly by iterator $mce->gather( $mce->chunk_id, { wid => $mce->wid, result => $mce->wid * 2 }); }; foreach my $href (@results) { print $href->{wid} .": ". $href->{result} ."\n"; } -- Output 1: 2 2: 4 3: 6 4: 8 5: 10 6: 12 7: 14 8: 16 =head2 gather => MCE::Candy::out_iter_fh( $fh ) use MCE::Flow; use MCE::Candy; open my $fh, '>', '/tmp/out.txt'; mce_flow { max_workers => 'auto', ## See get_ncpu in gather => MCE::Candy::out_iter_fh($fh) }, sub { my $output = "# Worker ID: " . MCE->wid . "\n"; ## Append results to $output string $output .= (MCE->wid * 2) . "\n\n"; ## Output will become orderly by iterator MCE->gather( MCE->wid, $output ); }; close $fh; -- Output # Worker ID: 1 2 # Worker ID: 2 4 # Worker ID: 3 6 # Worker ID: 4 8 # Worker ID: 5 10 # Worker ID: 6 12 # Worker ID: 7 14 # Worker ID: 8 16 =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.810/lib/MCE/Subs.pm0000644000175000017500000002476513022712426013570 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## Exports functions mapped directly to MCE methods. ## ############################################################################### package MCE::Subs; use strict; use warnings; no warnings qw( threads recursion uninitialized ); our $VERSION = '1.810'; ## no critic (Subroutines::ProhibitSubroutinePrototypes) ## no critic (TestingAndDebugging::ProhibitNoStrict) use MCE; use MCE::Relay; ############################################################################### ## ---------------------------------------------------------------------------- ## Import routine. ## ############################################################################### sub import { my $_class = shift; my $_g_flg = 0; my $_m_flg = 0; my $_w_flg = 0; my $_flag = sub { 1 }; my $_package = caller; ## Process module arguments. while (my $_argument = shift) { my $_arg = lc $_argument; $_g_flg = $_flag->() and next if ( $_arg eq ':getter' ); $_m_flg = $_flag->() and next if ( $_arg eq ':manager' ); $_w_flg = $_flag->() and next if ( $_arg eq ':worker' ); _croak("Error: ($_argument) invalid module option"); } $_m_flg = $_w_flg = 1 if ($_m_flg + $_w_flg == 0); _export_subs($_package, $_g_flg, $_m_flg, $_w_flg); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Define functions. ## ############################################################################### ## Callable by the manager process only. sub mce_restart_worker (@) { return $MCE::MCE->restart_worker(@_); } sub mce_forchunk (@) { return $MCE::MCE->forchunk(@_); } sub mce_foreach (@) { return $MCE::MCE->foreach(@_); } sub mce_forseq (@) { return $MCE::MCE->forseq(@_); } sub mce_process (@) { return $MCE::MCE->process(@_); } sub mce_relay_final ( ) { return $MCE::MCE->relay_final(); } sub mce_run (@) { return $MCE::MCE->run(@_); } sub mce_send (@) { return $MCE::MCE->send(@_); } sub mce_shutdown ( ) { return $MCE::MCE->shutdown(); } sub mce_spawn ( ) { return $MCE::MCE->spawn(); } sub mce_status ( ) { return $MCE::MCE->status(); } ## Callable by the worker process only. sub mce_do (@) { return $MCE::MCE->do(@_); } sub mce_exit (@) { return $MCE::MCE->exit(@_); } sub mce_gather (@) { return $MCE::MCE->gather(@_); } sub mce_last ( ) { return $MCE::MCE->last(); } sub mce_next ( ) { return $MCE::MCE->next(); } sub mce_relay (;&) { return $MCE::MCE->relay(@_); } sub mce_relay_recv ( ) { return $MCE::MCE->relay_recv(); } sub mce_sendto (;*@) { return $MCE::MCE->sendto(@_); } sub mce_sync ( ) { return $MCE::MCE->sync(); } sub mce_yield ( ) { return $MCE::MCE->yield(); } ## Callable by both the manager and worker processes. sub mce_abort ( ) { return $MCE::MCE->abort(); } sub mce_freeze (@) { return $MCE::MCE->{freeze}(@_); } sub mce_print (;*@) { return $MCE::MCE->print(@_); } sub mce_printf (;*@) { return $MCE::MCE->printf(@_); } sub mce_say (;*@) { return $MCE::MCE->say(@_); } sub mce_thaw (@) { return $MCE::MCE->{thaw}(@_); } ## Callable by both the manager and worker processes. sub mce_chunk_id ( ) { return $MCE::MCE->chunk_id(); } sub mce_chunk_size ( ) { return $MCE::MCE->chunk_size(); } sub mce_max_retries ( ) { return $MCE::MCE->max_retries(); } sub mce_max_workers ( ) { return $MCE::MCE->max_workers(); } sub mce_pid ( ) { return $MCE::MCE->pid(); } sub mce_sess_dir ( ) { return $MCE::MCE->sess_dir(); } sub mce_task_id ( ) { return $MCE::MCE->task_id(); } sub mce_task_name ( ) { return $MCE::MCE->task_name(); } sub mce_task_wid ( ) { return $MCE::MCE->task_wid(); } sub mce_tmp_dir ( ) { return $MCE::MCE->tmp_dir(); } sub mce_user_args ( ) { return $MCE::MCE->user_args(); } sub mce_wid ( ) { return $MCE::MCE->wid(); } ############################################################################### ## ---------------------------------------------------------------------------- ## Private methods. ## ############################################################################### sub _croak { goto &MCE::_croak; } sub _export_subs { my ($_package, $_g_flg, $_m_flg, $_w_flg) = @_; no strict 'refs'; no warnings 'redefine'; ## Callable by the manager process only. if ($_m_flg) { *{ $_package . '::mce_restart_worker' } = \&mce_restart_worker; *{ $_package . '::mce_forchunk' } = \&mce_forchunk; *{ $_package . '::mce_foreach' } = \&mce_foreach; *{ $_package . '::mce_forseq' } = \&mce_forseq; *{ $_package . '::mce_process' } = \&mce_process; *{ $_package . '::mce_relay_final' } = \&mce_relay_final; *{ $_package . '::mce_run' } = \&mce_run; *{ $_package . '::mce_send' } = \&mce_send; *{ $_package . '::mce_shutdown' } = \&mce_shutdown; *{ $_package . '::mce_spawn' } = \&mce_spawn; *{ $_package . '::mce_status' } = \&mce_status; } ## Callable by the worker process only. if ($_w_flg) { *{ $_package . '::mce_do' } = \&mce_do; *{ $_package . '::mce_exit' } = \&mce_exit; *{ $_package . '::mce_gather' } = \&mce_gather; *{ $_package . '::mce_last' } = \&mce_last; *{ $_package . '::mce_next' } = \&mce_next; *{ $_package . '::mce_relay' } = \&mce_relay; *{ $_package . '::mce_relay_recv' } = \&mce_relay_recv; *{ $_package . '::mce_sendto' } = \&mce_sendto; *{ $_package . '::mce_sync' } = \&mce_sync; *{ $_package . '::mce_yield' } = \&mce_yield; } ## Callable by both the manager and worker processes. if ($_m_flg || $_w_flg) { *{ $_package . '::mce_abort' } = \&mce_abort; *{ $_package . '::mce_freeze' } = \&mce_freeze; *{ $_package . '::mce_print' } = \&mce_print; *{ $_package . '::mce_printf' } = \&mce_printf; *{ $_package . '::mce_say' } = \&mce_say; *{ $_package . '::mce_thaw' } = \&mce_thaw; } if ($_g_flg) { *{ $_package . '::mce_chunk_id' } = \&mce_chunk_id; *{ $_package . '::mce_chunk_size' } = \&mce_chunk_size; *{ $_package . '::mce_max_retries' } = \&mce_max_retries; *{ $_package . '::mce_max_workers' } = \&mce_max_workers; *{ $_package . '::mce_pid' } = \&mce_pid; *{ $_package . '::mce_sess_dir' } = \&mce_sess_dir; *{ $_package . '::mce_task_id' } = \&mce_task_id; *{ $_package . '::mce_task_name' } = \&mce_task_name; *{ $_package . '::mce_task_wid' } = \&mce_task_wid; *{ $_package . '::mce_tmp_dir' } = \&mce_tmp_dir; *{ $_package . '::mce_user_args' } = \&mce_user_args; *{ $_package . '::mce_wid' } = \&mce_wid; } return; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Subs - Exports functions mapped directly to MCE methods =head1 VERSION This document describes MCE::Subs version 1.810 =head1 SYNOPSIS use MCE::Subs; ## Exports manager and worker functions only ## Getter functions are not exported by default use MCE::Subs qw( :getter ); ## All, including getter functions use MCE::Subs qw( :manager ); ## Exports manager functions only use MCE::Subs qw( :worker ); ## Exports worker functions only use MCE::Subs qw( :getter :worker ); ## Excludes manager functions =head1 DESCRIPTION This module exports functions mapped to MCE methods. All exported functions are prototyped, therefore allowing one to call them without using parentheses. use MCE::Subs qw( :worker ); sub user_func { my $wid = MCE->wid; mce_say "A: $wid"; mce_sync; mce_say "B: $wid"; mce_sync; mce_say "C: $wid"; mce_sync; return; } MCE->new( max_workers => 24, user_func => \&user_func ); mce_run 0 for (1..100); ## 0 means do not shutdown after running For the next example, we only want the worker functions to be exported due to using MCE::Map, which takes care of creating a MCE instance and running. use MCE::Map; use MCE::Subs qw( :worker ); ## The following serializes output to STDOUT and gathers $_ to @a. ## mce_say displays $_ when called without arguments. my @a = mce_map { mce_say; $_ } 1 .. 100; print scalar @a, "\n"; Unlike the native Perl functions, printf, print, and say methods require the comma after the glob reference or file handle. MCE->printf(\*STDERR, "%s\n", $error_msg); MCE->print(\*STDERR, $error_msg, "\n"); MCE->say(\*STDERR, $error_msg); MCE->say($fh, $error_msg); mce_printf \*STDERR, "%s\n", $error_msg; mce_print \*STDERR, $error_msg, "\n"; mce_say \*STDERR, $error_msg; mce_say $fh, $error_msg; =head1 FUNCTIONS for the MANAGER PROCESS via ( :manager ) MCE methods are described in L. =over 3 =item * mce_abort =item * mce_forchunk =item * mce_foreach =item * mce_forseq =item * mce_freeze =item * mce_process =item * mce_relay_final =item * mce_restart_worker =item * mce_run =item * mce_print =item * mce_printf =item * mce_say =item * mce_send =item * mce_shutdown =item * mce_spawn =item * mce_status =item * mce_thaw =back =head1 FUNCTIONS for MCE WORKERS via ( :worker ) MCE methods are described in L. =over 3 =item * mce_abort =item * mce_do =item * mce_exit =item * mce_freeze =item * mce_gather =item * mce_last =item * mce_next =item * mce_print =item * mce_printf =item * mce_relay =item * mce_relay_recv =item * mce_say =item * mce_sendto =item * mce_sync =item * mce_thaw =item * mce_yield =back =head1 GETTERS for MCE ATTRIBUTES via ( :getter ) MCE methods are described in L. =over 3 =item * mce_chunk_id =item * mce_chunk_size =item * mce_max_retries =item * mce_max_workers =item * mce_pid =item * mce_sess_dir =item * mce_task_id =item * mce_task_name =item * mce_task_wid =item * mce_tmp_dir =item * mce_user_args =item * mce_wid =back =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.810/lib/MCE/Flow.pm0000644000175000017500000010366213022712376013561 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## Parallel flow model for building creative applications. ## ############################################################################### package MCE::Flow; use strict; use warnings; no warnings qw( threads recursion uninitialized ); our $VERSION = '1.810'; ## no critic (BuiltinFunctions::ProhibitStringyEval) ## no critic (Subroutines::ProhibitSubroutinePrototypes) ## no critic (TestingAndDebugging::ProhibitNoStrict) use Scalar::Util qw( looks_like_number ); use MCE; our @CARP_NOT = qw( MCE ); my $_has_threads = $INC{'threads.pm'} ? 1 : 0; my $_tid = $_has_threads ? threads->tid() : 0; sub CLONE { $_tid = threads->tid() if $_has_threads; } ############################################################################### ## ---------------------------------------------------------------------------- ## Import routine. ## ############################################################################### my ($_MCE, $_def, $_params, $_tag) = ({}, {}, {}, 'MCE::Flow'); my ($_prev_c, $_prev_n, $_prev_t, $_prev_w) = ({}, {}, {}, {}); my ($_user_tasks) = ({}); sub import { my ($_class, $_pkg) = (shift, caller); my $_p = $_def->{$_pkg} = { MAX_WORKERS => 'auto', CHUNK_SIZE => 'auto', }; ## Import functions. no strict 'refs'; no warnings 'redefine'; *{ $_pkg.'::mce_flow_f' } = \&run_file; *{ $_pkg.'::mce_flow_s' } = \&run_seq; *{ $_pkg.'::mce_flow' } = \&run; ## Process module arguments. while ( my $_argument = shift ) { my $_arg = lc $_argument; $_p->{MAX_WORKERS} = shift, next if ( $_arg eq 'max_workers' ); $_p->{CHUNK_SIZE} = shift, next if ( $_arg eq 'chunk_size' ); $_p->{TMP_DIR} = shift, next if ( $_arg eq 'tmp_dir' ); $_p->{FREEZE} = shift, next if ( $_arg eq 'freeze' ); $_p->{THAW} = shift, next if ( $_arg eq 'thaw' ); ## Sereal 3.008+, if available, is used automatically by MCE 1.800. if ( $_arg eq 'sereal' ) { if ( shift eq '0' ) { require Storable; $_p->{FREEZE} = \&Storable::freeze; $_p->{THAW} = \&Storable::thaw; } next; } _croak("Error: ($_argument) invalid module option"); } $_p->{MAX_WORKERS} = MCE::Util::_parse_max_workers($_p->{MAX_WORKERS}); _validate_number($_p->{MAX_WORKERS}, 'MAX_WORKERS'); _validate_number($_p->{CHUNK_SIZE}, 'CHUNK_SIZE') unless ($_p->{CHUNK_SIZE} eq 'auto'); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Init and finish routines. ## ############################################################################### sub init (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Flow'); my $_pkg = "$$.$_tid.".caller(); $_params->{$_pkg} = (ref $_[0] eq 'HASH') ? shift : { @_ }; @_ = (); return; } sub finish (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Flow'); my $_pkg = (defined $_[0]) ? shift : "$$.$_tid.".caller(); if ( $_pkg eq 'MCE' ) { for my $_k ( keys %{ $_MCE } ) { MCE::Flow->finish($_k, 1); } } elsif ( $_MCE->{$_pkg} && $_MCE->{$_pkg}{_init_pid} eq "$$.$_tid" ) { $_MCE->{$_pkg}->shutdown(@_) if $_MCE->{$_pkg}{_spawned}; delete $_user_tasks->{$_pkg}; delete $_prev_c->{$_pkg}; delete $_prev_n->{$_pkg}; delete $_prev_t->{$_pkg}; delete $_prev_w->{$_pkg}; delete $_MCE->{$_pkg}; } @_ = (); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Parallel flow with MCE -- file. ## ############################################################################### sub run_file (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Flow'); my ($_file, $_pos); my $_start_pos = (ref $_[0] eq 'HASH') ? 2 : 1; my $_pid = "$$.$_tid.".caller(); if (defined (my $_p = $_params->{$_pid})) { delete $_p->{input_data} if (exists $_p->{input_data}); delete $_p->{sequence} if (exists $_p->{sequence}); } else { $_params->{$_pid} = {}; } for my $_i ($_start_pos .. @_ - 1) { my $_r = ref $_[$_i]; if ($_r eq '' || $_r eq 'SCALAR' || $_r =~ /^(?:GLOB|FileHandle|IO::)/) { $_file = $_[$_i]; $_pos = $_i; last; } } if (defined $_file && ref $_file eq '' && $_file ne '') { _croak("$_tag: ($_file) does not exist") unless (-e $_file); _croak("$_tag: ($_file) is not readable") unless (-r $_file); _croak("$_tag: ($_file) is not a plain file") unless (-f $_file); $_params->{$_pid}{_file} = $_file; } elsif (ref $_file eq 'SCALAR' || ref($_file) =~ /^(?:GLOB|FileHandle|IO::)/) { $_params->{$_pid}{_file} = $_file; } else { _croak("$_tag: (file) is not specified or valid"); } if (defined $_pos) { pop @_ for ($_pos .. @_ - 1); } return run(@_); } ############################################################################### ## ---------------------------------------------------------------------------- ## Parallel flow with MCE -- sequence. ## ############################################################################### sub run_seq (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Flow'); my ($_begin, $_end, $_pos); my $_start_pos = (ref $_[0] eq 'HASH') ? 2 : 1; my $_pid = "$$.$_tid.".caller(); if (defined (my $_p = $_params->{$_pid})) { delete $_p->{sequence} if (exists $_p->{sequence}); delete $_p->{input_data} if (exists $_p->{input_data}); delete $_p->{_file} if (exists $_p->{_file}); } else { $_params->{$_pid} = {}; } for my $_i ($_start_pos .. @_ - 1) { my $_ref = ref $_[$_i]; if ($_ref eq '' || $_ref eq 'HASH' || $_ref eq 'ARRAY') { $_pos = $_i; if ($_ref eq '') { $_begin = $_[$_pos]; $_end = $_[$_pos + 1]; $_params->{$_pid}{sequence} = [ $_[$_pos], $_[$_pos + 1], $_[$_pos + 2], $_[$_pos + 3] ]; } elsif ($_ref eq 'HASH') { $_begin = $_[$_pos]->{begin}; $_end = $_[$_pos]->{end}; $_params->{$_pid}{sequence} = $_[$_pos]; } elsif ($_ref eq 'ARRAY') { $_begin = $_[$_pos]->[0]; $_end = $_[$_pos]->[1]; $_params->{$_pid}{sequence} = $_[$_pos]; } last; } } _croak("$_tag: (sequence) is not specified or valid") unless (exists $_params->{$_pid}{sequence}); _croak("$_tag: (begin) is not specified for sequence") unless (defined $_begin); _croak("$_tag: (end) is not specified for sequence") unless (defined $_end); $_params->{$_pid}{sequence_run} = 1; if (defined $_pos) { pop @_ for ($_pos .. @_ - 1); } return run(@_); } ############################################################################### ## ---------------------------------------------------------------------------- ## Parallel flow with MCE. ## ############################################################################### sub run (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Flow'); my $_pkg = caller() eq 'MCE::Flow' ? caller(1) : caller(); my $_pid = "$$.$_tid.$_pkg"; if (ref $_[0] eq 'HASH') { $_params->{$_pid} = {} unless defined $_params->{$_pid}; for my $_p (keys %{ $_[0] }) { $_params->{$_pid}{$_p} = $_[0]->{$_p}; } shift; } ## ------------------------------------------------------------------------- my (@_code, @_name, @_thrs, @_wrks); my $_init_mce = 0; my $_pos = 0; while (ref $_[0] eq 'CODE') { push @_code, $_[0]; if (defined (my $_p = $_params->{$_pid})) { push @_name, (ref $_p->{task_name} eq 'ARRAY') ? $_p->{task_name}->[$_pos] : undef; push @_thrs, (ref $_p->{use_threads} eq 'ARRAY') ? $_p->{use_threads}->[$_pos] : undef; push @_wrks, (ref $_p->{max_workers} eq 'ARRAY') ? $_p->{max_workers}->[$_pos] : undef; } $_init_mce = 1 if ( !defined $_prev_c->{$_pid}[$_pos] || $_prev_c->{$_pid}[$_pos] != $_code[$_pos] ); $_init_mce = 1 if ($_prev_n->{$_pid}[$_pos] ne $_name[$_pos]); $_init_mce = 1 if ($_prev_t->{$_pid}[$_pos] ne $_thrs[$_pos]); $_init_mce = 1 if ($_prev_w->{$_pid}[$_pos] ne $_wrks[$_pos]); $_prev_c->{$_pid}[$_pos] = $_code[$_pos]; $_prev_n->{$_pid}[$_pos] = $_name[$_pos]; $_prev_t->{$_pid}[$_pos] = $_thrs[$_pos]; $_prev_w->{$_pid}[$_pos] = $_wrks[$_pos]; shift; $_pos++; } if (defined $_prev_c->{$_pid}[$_pos]) { pop @{ $_prev_c->{$_pid} } for ($_pos .. $#{ $_prev_c->{$_pid } }); pop @{ $_prev_n->{$_pid} } for ($_pos .. $#{ $_prev_n->{$_pid } }); pop @{ $_prev_t->{$_pid} } for ($_pos .. $#{ $_prev_t->{$_pid } }); pop @{ $_prev_w->{$_pid} } for ($_pos .. $#{ $_prev_w->{$_pid } }); $_init_mce = 1; } return unless (scalar @_code); ## ------------------------------------------------------------------------- my $_input_data; my $_max_workers = $_def->{$_pkg}{MAX_WORKERS}; my $_r = ref $_[0]; if ($_r eq 'ARRAY' || $_r eq 'SCALAR' || $_r =~ /^(?:GLOB|FileHandle|IO::)/) { $_input_data = shift if (@_ == 1); } if (defined (my $_p = $_params->{$_pid})) { $_max_workers = MCE::Util::_parse_max_workers($_p->{max_workers}) if (exists $_p->{max_workers} && ref $_p->{max_workers} ne 'ARRAY'); delete $_p->{sequence} if (defined $_input_data || scalar @_); delete $_p->{user_func} if (exists $_p->{user_func}); delete $_p->{user_tasks} if (exists $_p->{user_tasks}); } if (@_code > 1 && $_max_workers > 1) { $_max_workers = int($_max_workers / @_code + 0.5) + 1; } my $_chunk_size = MCE::Util::_parse_chunk_size( $_def->{$_pkg}{CHUNK_SIZE}, $_max_workers, $_params->{$_pid}, $_input_data, scalar @_ ); if (defined (my $_p = $_params->{$_pid})) { if (exists $_p->{_file}) { $_input_data = delete $_p->{_file}; } else { $_input_data = $_p->{input_data} if exists $_p->{input_data}; } } ## ------------------------------------------------------------------------- MCE::_save_state(); if ($_init_mce) { $_MCE->{$_pid}->shutdown() if (defined $_MCE->{$_pid}); ## must clear arrays for nested session to work with Perl < v5.14 _gen_user_tasks($_pid, [@_code], [@_name], [@_thrs], [@_wrks]); @_code = @_name = @_thrs = @_wrks = (); my %_opts = ( max_workers => $_max_workers, task_name => $_tag, user_tasks => $_user_tasks->{$_pid}, ); if (defined (my $_p = $_params->{$_pid})) { local $_; for (keys %{ $_p }) { next if ($_ eq 'max_workers' && ref $_p->{max_workers} eq 'ARRAY'); next if ($_ eq 'task_name' && ref $_p->{task_name} eq 'ARRAY'); next if ($_ eq 'use_threads' && ref $_p->{use_threads} eq 'ARRAY'); next if ($_ eq 'chunk_size'); next if ($_ eq 'input_data'); next if ($_ eq 'sequence_run'); _croak("MCE::Flow: ($_) is not a valid constructor argument") unless (exists $MCE::_valid_fields_new{$_}); $_opts{$_} = $_p->{$_}; } } for my $_k (qw/ tmp_dir freeze thaw /) { $_opts{$_k} = $_def->{$_pkg}{uc($_k)} if (exists $_def->{$_pkg}{uc($_k)} && !exists $_opts{$_k}); } $_MCE->{$_pid} = MCE->new(pkg => $_pkg, %_opts); } else { ## Workers may persist after running. Thus, updating the MCE instance. ## These options do not require respawning. if (defined (my $_p = $_params->{$_pid})) { for my $_k (qw( RS interval stderr_file stdout_file user_error user_output job_delay submit_delay on_post_exit on_post_run user_args flush_file flush_stderr flush_stdout gather max_retries )) { $_MCE->{$_pid}{$_k} = $_p->{$_k} if (exists $_p->{$_k}); } } } ## ------------------------------------------------------------------------- my @_a; my $_wa = wantarray; $_MCE->{$_pid}{gather} = \@_a if (defined $_wa); if (defined $_input_data) { @_ = (); $_MCE->{$_pid}->process({ chunk_size => $_chunk_size }, $_input_data); delete $_MCE->{$_pid}{input_data}; } elsif (scalar @_) { $_MCE->{$_pid}->process({ chunk_size => $_chunk_size }, \@_); delete $_MCE->{$_pid}{input_data}; } else { if (defined $_params->{$_pid} && exists $_params->{$_pid}{sequence}) { $_MCE->{$_pid}->run({ chunk_size => $_chunk_size, sequence => $_params->{$_pid}{sequence} }, 0); if (exists $_params->{$_pid}{sequence_run}) { delete $_params->{$_pid}{sequence_run}; delete $_params->{$_pid}{sequence}; } delete $_MCE->{$_pid}{sequence}; } else { $_MCE->{$_pid}->run({ chunk_size => $_chunk_size }, 0); } } MCE::_restore_state(); delete $_MCE->{$_pid}{gather} if (defined $_wa); return ((defined $_wa) ? @_a : ()); } ############################################################################### ## ---------------------------------------------------------------------------- ## Private methods. ## ############################################################################### sub _croak { goto &MCE::_croak; } sub _gen_user_tasks { my ($_pid, $_code_ref, $_name_ref, $_thrs_ref, $_wrks_ref) = @_; @{ $_user_tasks->{$_pid} } = (); for (my $_i = 0; $_i < @{ $_code_ref }; $_i++) { push @{ $_user_tasks->{$_pid} }, { task_name => $_name_ref->[$_i], use_threads => $_thrs_ref->[$_i], max_workers => $_wrks_ref->[$_i], user_func => $_code_ref->[$_i] } } return; } sub _validate_number { my ($_n, $_key) = @_; _croak("$_tag: ($_key) is not valid") if (!defined $_n); $_n =~ s/K\z//i; $_n =~ s/M\z//i; if (!looks_like_number($_n) || int($_n) != $_n || $_n < 1) { _croak("$_tag: ($_key) is not valid"); } return; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Flow - Parallel flow model for building creative applications =head1 VERSION This document describes MCE::Flow version 1.810 =head1 DESCRIPTION MCE::Flow is great for writing custom apps to maximize on all available cores. This module was created to help one harness user_tasks within MCE. It is trivial to parallelize with mce_stream shown below. ## Native map function my @a = map { $_ * 4 } map { $_ * 3 } map { $_ * 2 } 1..10000; ## Same as with MCE::Stream (processing from right to left) @a = mce_stream sub { $_ * 4 }, sub { $_ * 3 }, sub { $_ * 2 }, 1..10000; ## Pass an array reference to have writes occur simultaneously mce_stream \@a, sub { $_ * 4 }, sub { $_ * 3 }, sub { $_ * 2 }, 1..10000; However, let's have MCE::Flow compute the same in parallel. MCE::Queue will be used for data flow among the sub-tasks. use MCE::Flow; use MCE::Queue; This calls for preserving output order. sub preserve_order { my %tmp; my $order_id = 1; my $gather_ref = $_[0]; @{ $gather_ref } = (); ## clear the array (optional) return sub { my ($data_ref, $chunk_id) = @_; $tmp{$chunk_id} = $data_ref; while (1) { last unless exists $tmp{$order_id}; push @{ $gather_ref }, @{ delete $tmp{$order_id++} }; } return; }; } Two queues are needed for data flow between the 3 sub-tasks. Notice task_end and how the value from $task_name is used for determining which task has ended. my $b = MCE::Queue->new; my $c = MCE::Queue->new; sub task_end { my ($mce, $task_id, $task_name) = @_; if (defined $mce->{user_tasks}->[$task_id + 1]) { my $n_workers = $mce->{user_tasks}->[$task_id + 1]->{max_workers}; if ($task_name eq 'a') { $b->enqueue((undef) x $n_workers); } elsif ($task_name eq 'b') { $c->enqueue((undef) x $n_workers); } } return; } Next are the 3 sub-tasks. The first one reads input and begins the flow. The 2nd task dequeues, performs the calculation, and enqueues into the next. Finally, the last task calls the gather method. Although serialization is done for you automatically, it is done here to save from double serialization. This is the fastest approach for passing data between sub-tasks. Thus, the least overhead. sub task_a { my @ans; my ($mce, $chunk_ref, $chunk_id) = @_; push @ans, map { $_ * 2 } @{ $chunk_ref }; $b->enqueue(MCE->freeze([ \@ans, $chunk_id ])); return; } sub task_b { my ($mce) = @_; while (1) { my @ans; my $chunk = $b->dequeue; last unless defined $chunk; $chunk = MCE->thaw($chunk); push @ans, map { $_ * 3 } @{ $chunk->[0] }; $c->enqueue(MCE->freeze([ \@ans, $chunk->[1] ])); } return; } sub task_c { my ($mce) = @_; while (1) { my @ans; my $chunk = $c->dequeue; last unless defined $chunk; $chunk = MCE->thaw($chunk); push @ans, map { $_ * 4 } @{ $chunk->[0] }; MCE->gather(\@ans, $chunk->[1]); } return; } In summary, MCE::Flow builds out a MCE instance behind the scene and starts running. The task_name (shown), max_workers, and use_threads options can take an anonymous array for specifying the values uniquely per each sub-task. my @a; mce_flow { task_name => [ 'a', 'b', 'c' ], task_end => \&task_end, gather => preserve_order(\@a) }, \&task_a, \&task_b, \&task_c, 1..10000; print "@a\n"; If speed is not a concern and wanting to rid of all the MCE->freeze and MCE->thaw statements, simply enqueue and dequeue 2 items at a time. Or better yet, see L introduced in MCE 1.506. First, task_end must be updated. The number of undef(s) must match the number of workers times the dequeue count. Otherwise, the script will stall. sub task_end { ... if ($task_name eq 'a') { # $b->enqueue((undef) x $n_workers); $b->enqueue((undef) x ($n_workers * 2)); } elsif ($task_name eq 'b') { # $c->enqueue((undef) x $n_workers); $c->enqueue((undef) x ($n_workers * 2)); } ... } Next, the 3 sub-tasks enqueuing and dequeuing 2 elements at a time. sub task_a { my @ans; my ($mce, $chunk_ref, $chunk_id) = @_; push @ans, map { $_ * 2 } @{ $chunk_ref }; $b->enqueue(\@ans, $chunk_id); return; } sub task_b { my ($mce) = @_; while (1) { my @ans; my ($chunk_ref, $chunk_id) = $b->dequeue(2); last unless defined $chunk_ref; push @ans, map { $_ * 3 } @{ $chunk_ref }; $c->enqueue(\@ans, $chunk_id); } return; } sub task_c { my ($mce) = @_; while (1) { my @ans; my ($chunk_ref, $chunk_id) = $c->dequeue(2); last unless defined $chunk_ref; push @ans, map { $_ * 4 } @{ $chunk_ref }; MCE->gather(\@ans, $chunk_id); } return; } Finally, run as usual. my @a; mce_flow { task_name => [ 'a', 'b', 'c' ], task_end => \&task_end, gather => preserve_order(\@a) }, \&task_a, \&task_b, \&task_c, 1..10000; print "@a\n"; =head1 SYNOPSIS when CHUNK_SIZE EQUALS 1 Although L may be preferred for running using a single code block, the text below also applies to this module, particularly for the first block. All models in MCE default to 'auto' for chunk_size. The arguments for the block are the same as writing a user_func block using the Core API. Beginning with MCE 1.5, the next input item is placed into the input scalar variable $_ when chunk_size equals 1. Otherwise, $_ points to $chunk_ref containing many items. Basically, line 2 below may be omitted from your code when using $_. One can call MCE->chunk_id to obtain the current chunk id. line 1: user_func => sub { line 2: my ($mce, $chunk_ref, $chunk_id) = @_; line 3: line 4: $_ points to $chunk_ref->[0] line 5: in MCE 1.5 when chunk_size == 1 line 6: line 7: $_ points to $chunk_ref line 8: in MCE 1.5 when chunk_size > 1 line 9: } Follow this synopsis when chunk_size equals one. Looping is not required from inside the first block. Hence, the block is called once per each item. ## Exports mce_flow, mce_flow_f, and mce_flow_s use MCE::Flow; MCE::Flow::init { chunk_size => 1 }; ## Array or array_ref mce_flow sub { do_work($_) }, 1..10000; mce_flow sub { do_work($_) }, [ 1..10000 ]; ## File_path, glob_ref, or scalar_ref mce_flow_f sub { chomp; do_work($_) }, "/path/to/file"; mce_flow_f sub { chomp; do_work($_) }, $file_handle; mce_flow_f sub { chomp; do_work($_) }, \$scalar; ## Sequence of numbers (begin, end [, step, format]) mce_flow_s sub { do_work($_) }, 1, 10000, 5; mce_flow_s sub { do_work($_) }, [ 1, 10000, 5 ]; mce_flow_s sub { do_work($_) }, { begin => 1, end => 10000, step => 5, format => undef }; =head1 SYNOPSIS when CHUNK_SIZE is GREATER THAN 1 Follow this synopsis when chunk_size equals 'auto' or greater than 1. This means having to loop through the chunk from inside the first block. use MCE::Flow; MCE::Flow::init { ## Chunk_size defaults to 'auto' when chunk_size => 'auto' ## not specified. Therefore, the init }; ## function may be omitted. ## Syntax is shown for mce_flow for demonstration purposes. ## Looping inside the block is the same for mce_flow_f and ## mce_flow_s. mce_flow sub { do_work($_) for (@{ $_ }) }, 1..10000; ## Same as above, resembles code using the Core API. mce_flow sub { my ($mce, $chunk_ref, $chunk_id) = @_; for (@{ $chunk_ref }) { do_work($_); } }, 1..10000; Chunking reduces the number of IPC calls behind the scene. Think in terms of chunks whenever processing a large amount of data. For relatively small data, choosing 1 for chunk_size is fine. =head1 OVERRIDING DEFAULTS The following list options which may be overridden when loading the module. use Sereal qw( encode_sereal decode_sereal ); use CBOR::XS qw( encode_cbor decode_cbor ); use JSON::XS qw( encode_json decode_json ); use MCE::Flow max_workers => 8, # Default 'auto' chunk_size => 500, # Default 'auto' tmp_dir => "/path/to/app/tmp", # $MCE::Signal::tmp_dir freeze => \&encode_sereal, # \&Storable::freeze thaw => \&decode_sereal # \&Storable::thaw ; From MCE 1.8 onwards, Sereal 3.008+ is loaded automatically if available. Specify C 0> to use Storable instead. use MCE::Flow Sereal => 0; =head1 CUSTOMIZING MCE =over 3 =item MCE::Flow->init ( options ) =item MCE::Flow::init { options } The init function accepts a hash of MCE options. Unlike with MCE::Stream, both gather and bounds_only options may be specified when calling init (not shown below). use MCE::Flow; MCE::Flow::init { chunk_size => 1, max_workers => 4, user_begin => sub { print "## ", MCE->wid, " started\n"; }, user_end => sub { print "## ", MCE->wid, " completed\n"; } }; my %a = mce_flow sub { MCE->gather($_, $_ * $_) }, 1..100; print "\n", "@a{1..100}", "\n"; -- Output ## 3 started ## 2 started ## 4 started ## 1 started ## 2 completed ## 4 completed ## 3 completed ## 1 completed 1 4 9 16 25 36 49 64 81 100 121 144 169 196 225 256 289 324 361 400 441 484 529 576 625 676 729 784 841 900 961 1024 1089 1156 1225 1296 1369 1444 1521 1600 1681 1764 1849 1936 2025 2116 2209 2304 2401 2500 2601 2704 2809 2916 3025 3136 3249 3364 3481 3600 3721 3844 3969 4096 4225 4356 4489 4624 4761 4900 5041 5184 5329 5476 5625 5776 5929 6084 6241 6400 6561 6724 6889 7056 7225 7396 7569 7744 7921 8100 8281 8464 8649 8836 9025 9216 9409 9604 9801 10000 =back Like with MCE::Flow::init above, MCE options may be specified using an anonymous hash for the first argument. Notice how task_name, max_workers, and use_threads can take an anonymous array for setting uniquely per each code block. Unlike MCE::Stream which processes from right-to-left, MCE::Flow begins with the first code block, thus processing from left-to-right. use threads; use MCE::Flow; my @a = mce_flow { task_name => [ 'a', 'b', 'c' ], max_workers => [ 3, 4, 2, ], use_threads => [ 1, 0, 0, ], user_end => sub { my ($mce, $task_id, $task_name) = @_; MCE->print("$task_id - $task_name completed\n"); }, task_end => sub { my ($mce, $task_id, $task_name) = @_; MCE->print("$task_id - $task_name ended\n"); } }, sub { sleep 1; }, ## 3 workers, named a sub { sleep 2; }, ## 4 workers, named b sub { sleep 3; }; ## 2 workers, named c -- Output 0 - a completed 0 - a completed 0 - a completed 0 - a ended 1 - b completed 1 - b completed 1 - b completed 1 - b completed 1 - b ended 2 - c completed 2 - c completed 2 - c ended =head1 API DOCUMENTATION Although input data is optional for MCE::Flow, the following assumes chunk_size equals 1 in order to demonstrate all the possibilities of passing input data into the code block. =over 3 =item MCE::Flow->run ( { input_data => iterator }, sub { code } ) =item mce_flow { input_data => iterator }, sub { code } An iterator reference can by specified for input_data. The only other way is to specify input_data via MCE::Flow::init. This prevents MCE::Flow from configuring the iterator reference as another user task which will not work. Iterators are described under "SYNTAX for INPUT_DATA" at L. MCE::Flow::init { input_data => iterator }; mce_flow sub { $_ }; =item MCE::Flow->run ( sub { code }, list ) =item mce_flow sub { code }, list Input data can be defined using a list. mce_flow sub { $_ }, 1..1000; mce_flow sub { $_ }, [ 1..1000 ]; =item MCE::Flow->run_file ( sub { code }, file ) =item mce_flow_f sub { code }, file The fastest of these is the /path/to/file. Workers communicate the next offset position among themselves with zero interaction by the manager process. mce_flow_f sub { $_ }, "/path/to/file"; mce_flow_f sub { $_ }, $file_handle; mce_flow_f sub { $_ }, \$scalar; =item MCE::Flow->run_seq ( sub { code }, $beg, $end [, $step, $fmt ] ) =item mce_flow_s sub { code }, $beg, $end [, $step, $fmt ] Sequence can be defined as a list, an array reference, or a hash reference. The functions require both begin and end values to run. Step and format are optional. The format is passed to sprintf (% may be omitted below). my ($beg, $end, $step, $fmt) = (10, 20, 0.1, "%4.1f"); mce_flow_s sub { $_ }, $beg, $end, $step, $fmt; mce_flow_s sub { $_ }, [ $beg, $end, $step, $fmt ]; mce_flow_s sub { $_ }, { begin => $beg, end => $end, step => $step, format => $fmt }; The sequence engine can compute 'begin' and 'end' items only, for the chunk, and not the items in between (hence boundaries only). This option applies to sequence only and has no effect when chunk_size equals 1. The time to run is 0.006s below. This becomes 0.827s without the bounds_only option due to computing all items in between, thus creating a very large array. Basically, specify bounds_only => 1 when boundaries is all you need for looping inside the block; e.g. Monte Carlo simulations. Time was measured using 1 worker to emphasize the difference. use MCE::Flow; MCE::Flow::init { max_workers => 1, chunk_size => 1_250_000, bounds_only => 1 }; ## For sequence, the input scalar $_ points to $chunk_ref ## when chunk_size > 1, otherwise $chunk_ref->[0]. ## ## mce_flow_s sub { ## my $begin = $_->[0]; my $end = $_->[-1]; ## ## for ($begin .. $end) { ## ... ## } ## ## }, 1, 10_000_000; mce_flow_s sub { my ($mce, $chunk_ref, $chunk_id) = @_; ## $chunk_ref contains 2 items, not 1_250_000 my $begin = $chunk_ref->[ 0]; my $end = $chunk_ref->[-1]; ## or $chunk_ref->[1] MCE->printf("%7d .. %8d\n", $begin, $end); }, 1, 10_000_000; -- Output 1 .. 1250000 1250001 .. 2500000 2500001 .. 3750000 3750001 .. 5000000 5000001 .. 6250000 6250001 .. 7500000 7500001 .. 8750000 8750001 .. 10000000 =back =head1 GATHERING DATA Unlike MCE::Map where gather and output order are done for you automatically, the gather method is used to have results sent back to the manager process. use MCE::Flow chunk_size => 1; ## Output order is not guaranteed. my @a = mce_flow sub { MCE->gather($_ * 2) }, 1..100; print "@a\n\n"; ## Outputs to a hash instead (key, value). my %h1 = mce_flow sub { MCE->gather($_, $_ * 2) }, 1..100; print "@h1{1..100}\n\n"; ## This does the same thing due to chunk_id starting at one. my %h2 = mce_flow sub { MCE->gather(MCE->chunk_id, $_ * 2) }, 1..100; print "@h2{1..100}\n\n"; The gather method can be called multiple times within the block unlike return which would leave the block. Therefore, think of gather as yielding results immediately to the manager process without actually leaving the block. use MCE::Flow chunk_size => 1, max_workers => 3; my @hosts = qw( hosta hostb hostc hostd hoste ); my %h3 = mce_flow sub { my ($output, $error, $status); my $host = $_; ## Do something with $host; $output = "Worker ". MCE->wid .": Hello from $host"; if (MCE->chunk_id % 3 == 0) { ## Simulating an error condition local $? = 1; $status = $?; $error = "Error from $host" } else { $status = 0; } ## Ensure unique keys (key, value) when gathering to ## a hash. MCE->gather("$host.out", $output); MCE->gather("$host.err", $error) if (defined $error); MCE->gather("$host.sta", $status); }, @hosts; foreach my $host (@hosts) { print $h3{"$host.out"}, "\n"; print $h3{"$host.err"}, "\n" if (exists $h3{"$host.err"}); print "Exit status: ", $h3{"$host.sta"}, "\n\n"; } -- Output Worker 3: Hello from hosta Exit status: 0 Worker 2: Hello from hostb Exit status: 0 Worker 1: Hello from hostc Error from hostc Exit status: 1 Worker 3: Hello from hostd Exit status: 0 Worker 2: Hello from hoste Exit status: 0 The following uses an anonymous array containing 3 elements when gathering data. Serialization is automatic behind the scene. my %h3 = mce_flow sub { ... MCE->gather($host, [$output, $error, $status]); }, @hosts; foreach my $host (@hosts) { print $h3{$host}->[0], "\n"; print $h3{$host}->[1], "\n" if (defined $h3{$host}->[1]); print "Exit status: ", $h3{$host}->[2], "\n\n"; } Although MCE::Map comes to mind, one may want additional control when gathering data such as retaining output order. use MCE::Flow; sub preserve_order { my %tmp; my $order_id = 1; my $gather_ref = $_[0]; return sub { $tmp{ (shift) } = \@_; while (1) { last unless exists $tmp{$order_id}; push @{ $gather_ref }, @{ delete $tmp{$order_id++} }; } return; }; } ## Workers persist for the most part after running. Though, not always ## the case and depends on Perl. Pass a reference to a subroutine if ## workers must persist; e.g. mce_flow { ... }, \&foo, 1..100000. MCE::Flow::init { chunk_size => 'auto', max_workers => 'auto' }; for (1..2) { my @m2; mce_flow { gather => preserve_order(\@m2) }, sub { my @a; my ($mce, $chunk_ref, $chunk_id) = @_; ## Compute the entire chunk data at once. push @a, map { $_ * 2 } @{ $chunk_ref }; ## Afterwards, invoke the gather feature, which ## will direct the data to the callback function. MCE->gather(MCE->chunk_id, @a); }, 1..100000; print scalar @m2, "\n"; } MCE::Flow::finish; All 6 models support 'auto' for chunk_size unlike the Core API. Think of the models as the basis for providing JIT for MCE. They create the instance, tune max_workers, and tune chunk_size automatically regardless of the hardware. The following does the same thing using the Core API. Workers persist after running. use MCE; sub preserve_order { ... } my $mce = MCE->new( max_workers => 'auto', chunk_size => 8000, user_func => sub { my @a; my ($mce, $chunk_ref, $chunk_id) = @_; ## Compute the entire chunk data at once. push @a, map { $_ * 2 } @{ $chunk_ref }; ## Afterwards, invoke the gather feature, which ## will direct the data to the callback function. MCE->gather(MCE->chunk_id, @a); } ); for (1..2) { my @m2; $mce->process({ gather => preserve_order(\@m2) }, [1..100000]); print scalar @m2, "\n"; } $mce->shutdown; =head1 MANUAL SHUTDOWN =over 3 =item MCE::Flow->finish =item MCE::Flow::finish Workers remain persistent as much as possible after running. Shutdown occurs automatically when the script terminates. Call finish when workers are no longer needed. use MCE::Flow; MCE::Flow::init { chunk_size => 20, max_workers => 'auto' }; mce_flow sub { ... }, 1..100; MCE::Flow::finish; =back =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.810/lib/MCE/Map.pm0000644000175000017500000004654713022712404013367 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## Parallel map model similar to the native map function. ## ############################################################################### package MCE::Map; use strict; use warnings; no warnings qw( threads recursion uninitialized ); our $VERSION = '1.810'; ## no critic (BuiltinFunctions::ProhibitStringyEval) ## no critic (Subroutines::ProhibitSubroutinePrototypes) ## no critic (TestingAndDebugging::ProhibitNoStrict) use Scalar::Util qw( looks_like_number weaken ); use MCE; our @CARP_NOT = qw( MCE ); my $_has_threads = $INC{'threads.pm'} ? 1 : 0; my $_tid = $_has_threads ? threads->tid() : 0; sub CLONE { $_tid = threads->tid() if $_has_threads; } ############################################################################### ## ---------------------------------------------------------------------------- ## Import routine. ## ############################################################################### my ($_MCE, $_def, $_params, $_prev_c, $_tag) = ({}, {}, {}, {}, 'MCE::Map'); sub import { my ($_class, $_pkg) = (shift, caller); my $_p = $_def->{$_pkg} = { MAX_WORKERS => 'auto', CHUNK_SIZE => 'auto', }; ## Import functions. no strict 'refs'; no warnings 'redefine'; *{ $_pkg.'::mce_map_f' } = \&run_file; *{ $_pkg.'::mce_map_s' } = \&run_seq; *{ $_pkg.'::mce_map' } = \&run; ## Process module arguments. while ( my $_argument = shift ) { my $_arg = lc $_argument; $_p->{MAX_WORKERS} = shift, next if ( $_arg eq 'max_workers' ); $_p->{CHUNK_SIZE} = shift, next if ( $_arg eq 'chunk_size' ); $_p->{TMP_DIR} = shift, next if ( $_arg eq 'tmp_dir' ); $_p->{FREEZE} = shift, next if ( $_arg eq 'freeze' ); $_p->{THAW} = shift, next if ( $_arg eq 'thaw' ); ## Sereal 3.008+, if available, is used automatically by MCE 1.800. if ( $_arg eq 'sereal' ) { if ( shift eq '0' ) { require Storable; $_p->{FREEZE} = \&Storable::freeze; $_p->{THAW} = \&Storable::thaw; } next; } _croak("Error: ($_argument) invalid module option"); } $_p->{MAX_WORKERS} = MCE::Util::_parse_max_workers($_p->{MAX_WORKERS}); _validate_number($_p->{MAX_WORKERS}, 'MAX_WORKERS'); _validate_number($_p->{CHUNK_SIZE}, 'CHUNK_SIZE') unless ($_p->{CHUNK_SIZE} eq 'auto'); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Gather callback for storing by chunk_id => chunk_ref into a hash. ## ############################################################################### my ($_total_chunks, %_tmp); sub _gather { my ($_chunk_id, $_data_ref) = @_; $_tmp{$_chunk_id} = $_data_ref; $_total_chunks++; return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Init and finish routines. ## ############################################################################### sub init (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Map'); my $_pkg = "$$.$_tid.".caller(); $_params->{$_pkg} = (ref $_[0] eq 'HASH') ? shift : { @_ }; @_ = (); return; } sub finish (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Map'); my $_pkg = (defined $_[0]) ? shift : "$$.$_tid.".caller(); if ( $_pkg eq 'MCE' ) { for my $_k ( keys %{ $_MCE } ) { MCE::Map->finish($_k, 1); } } elsif ( $_MCE->{$_pkg} && $_MCE->{$_pkg}{_init_pid} eq "$$.$_tid" ) { $_MCE->{$_pkg}->shutdown(@_) if $_MCE->{$_pkg}{_spawned}; $_total_chunks = undef, undef %_tmp; delete $_prev_c->{$_pkg}; delete $_MCE->{$_pkg}; } @_ = (); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Parallel map with MCE -- file. ## ############################################################################### sub run_file (&@) { shift if (defined $_[0] && $_[0] eq 'MCE::Map'); my $_code = shift; my $_file = shift; my $_pid = "$$.$_tid.".caller(); if (defined (my $_p = $_params->{$_pid})) { delete $_p->{input_data} if (exists $_p->{input_data}); delete $_p->{sequence} if (exists $_p->{sequence}); } else { $_params->{$_pid} = {}; } if (defined $_file && ref $_file eq '' && $_file ne '') { _croak("$_tag: ($_file) does not exist") unless (-e $_file); _croak("$_tag: ($_file) is not readable") unless (-r $_file); _croak("$_tag: ($_file) is not a plain file") unless (-f $_file); $_params->{$_pid}{_file} = $_file; } elsif (ref $_file eq 'SCALAR' || ref($_file) =~ /^(?:GLOB|FileHandle|IO::)/) { $_params->{$_pid}{_file} = $_file; } else { _croak("$_tag: (file) is not specified or valid"); } @_ = (); return run($_code); } ############################################################################### ## ---------------------------------------------------------------------------- ## Parallel map with MCE -- sequence. ## ############################################################################### sub run_seq (&@) { shift if (defined $_[0] && $_[0] eq 'MCE::Map'); my $_code = shift; my $_pid = "$$.$_tid.".caller(); if (defined (my $_p = $_params->{$_pid})) { delete $_p->{input_data} if (exists $_p->{input_data}); delete $_p->{_file} if (exists $_p->{_file}); } else { $_params->{$_pid} = {}; } my ($_begin, $_end); if (ref $_[0] eq 'HASH') { $_begin = $_[0]->{begin}; $_end = $_[0]->{end}; $_params->{$_pid}{sequence} = $_[0]; } elsif (ref $_[0] eq 'ARRAY') { $_begin = $_[0]->[0]; $_end = $_[0]->[1]; $_params->{$_pid}{sequence} = $_[0]; } elsif (ref $_[0] eq '') { $_begin = $_[0]; $_end = $_[1]; $_params->{$_pid}{sequence} = [ @_ ]; } else { _croak("$_tag: (sequence) is not specified or valid"); } _croak("$_tag: (begin) is not specified for sequence") unless (defined $_begin); _croak("$_tag: (end) is not specified for sequence") unless (defined $_end); $_params->{$_pid}{sequence_run} = 1; @_ = (); return run($_code); } ############################################################################### ## ---------------------------------------------------------------------------- ## Parallel map with MCE. ## ############################################################################### sub run (&@) { shift if (defined $_[0] && $_[0] eq 'MCE::Map'); my $_code = shift; $_total_chunks = 0; undef %_tmp; my $_pkg = caller() eq 'MCE::Map' ? caller(1) : caller(); my $_pid = "$$.$_tid.$_pkg"; my $_input_data; my $_max_workers = $_def->{$_pkg}{MAX_WORKERS}; my $_r = ref $_[0]; if ($_r eq 'ARRAY' || $_r eq 'CODE' || $_r eq 'SCALAR' || $_r =~ /^(?:GLOB|FileHandle|IO::)/) { $_input_data = shift if (@_ == 1); } if (defined (my $_p = $_params->{$_pid})) { $_max_workers = MCE::Util::_parse_max_workers($_p->{max_workers}) if (exists $_p->{max_workers}); delete $_p->{sequence} if (defined $_input_data || scalar @_); delete $_p->{user_func} if (exists $_p->{user_func}); delete $_p->{user_tasks} if (exists $_p->{user_tasks}); delete $_p->{use_slurpio} if (exists $_p->{use_slurpio}); delete $_p->{bounds_only} if (exists $_p->{bounds_only}); delete $_p->{gather} if (exists $_p->{gather}); } my $_chunk_size = MCE::Util::_parse_chunk_size( $_def->{$_pkg}{CHUNK_SIZE}, $_max_workers, $_params->{$_pid}, $_input_data, scalar @_ ); if (defined (my $_p = $_params->{$_pid})) { if (exists $_p->{_file}) { $_input_data = delete $_p->{_file}; } else { $_input_data = $_p->{input_data} if exists $_p->{input_data}; } } ## ------------------------------------------------------------------------- MCE::_save_state(); if (!defined $_prev_c->{$_pid} || $_prev_c->{$_pid} != $_code) { $_MCE->{$_pid}->shutdown() if (defined $_MCE->{$_pid}); $_prev_c->{$_pid} = $_code; my %_opts = ( max_workers => $_max_workers, task_name => $_tag, user_func => sub { my ($_mce, $_chunk_ref, $_chunk_id) = @_; my $_wantarray = $_mce->{user_args}[0]; if ($_wantarray) { my @_a; if (ref $_chunk_ref eq 'SCALAR') { local $/ = $_mce->{RS} if defined $_mce->{RS}; open my $_MEM_FH, '<', $_chunk_ref; binmode $_MEM_FH, ':raw'; while (<$_MEM_FH>) { push @_a, &{ $_code }; } close $_MEM_FH; weaken $_MEM_FH; } else { if (ref $_chunk_ref) { push @_a, map { &{ $_code } } @{ $_chunk_ref }; } else { push @_a, map { &{ $_code } } $_chunk_ref; } } MCE->gather($_chunk_id, \@_a); } else { my $_cnt = 0; if (ref $_chunk_ref eq 'SCALAR') { local $/ = $_mce->{RS} if defined $_mce->{RS}; open my $_MEM_FH, '<', $_chunk_ref; binmode $_MEM_FH, ':raw'; while (<$_MEM_FH>) { $_cnt++; &{ $_code }; } close $_MEM_FH; weaken $_MEM_FH; } else { if (ref $_chunk_ref) { $_cnt += map { &{ $_code } } @{ $_chunk_ref }; } else { $_cnt += map { &{ $_code } } $_chunk_ref; } } MCE->gather($_cnt) if defined $_wantarray; } }, ); if (defined (my $_p = $_params->{$_pid})) { for my $_k (keys %{ $_p }) { next if ($_k eq 'sequence_run'); next if ($_k eq 'input_data'); next if ($_k eq 'chunk_size'); _croak("MCE::Map: ($_k) is not a valid constructor argument") unless (exists $MCE::_valid_fields_new{$_k}); $_opts{$_k} = $_p->{$_k}; } } for my $_k (qw/ tmp_dir freeze thaw /) { $_opts{$_k} = $_def->{$_pkg}{uc($_k)} if (exists $_def->{$_pkg}{uc($_k)} && !exists $_opts{$_k}); } $_MCE->{$_pid} = MCE->new(pkg => $_pkg, %_opts); } ## ------------------------------------------------------------------------- my $_cnt = 0; my $_wantarray = wantarray; $_MCE->{$_pid}{use_slurpio} = ($_chunk_size > &MCE::MAX_RECS_SIZE) ? 1 : 0; $_MCE->{$_pid}{user_args} = [ $_wantarray ]; $_MCE->{$_pid}{gather} = $_wantarray ? \&_gather : sub { $_cnt += $_[0]; return; }; if (defined $_input_data) { @_ = (); $_MCE->{$_pid}->process({ chunk_size => $_chunk_size }, $_input_data); delete $_MCE->{$_pid}{input_data}; } elsif (scalar @_) { $_MCE->{$_pid}->process({ chunk_size => $_chunk_size }, \@_); delete $_MCE->{$_pid}{input_data}; } else { if (defined $_params->{$_pid} && exists $_params->{$_pid}{sequence}) { $_MCE->{$_pid}->run({ chunk_size => $_chunk_size, sequence => $_params->{$_pid}{sequence} }, 0); if (exists $_params->{$_pid}{sequence_run}) { delete $_params->{$_pid}{sequence_run}; delete $_params->{$_pid}{sequence}; } delete $_MCE->{$_pid}{sequence}; } } MCE::_restore_state(); if ($_wantarray) { return map { @{ $_ } } delete @_tmp{ 1 .. $_total_chunks }; } elsif (defined $_wantarray) { return $_cnt; } return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Private methods. ## ############################################################################### sub _croak { goto &MCE::_croak; } sub _validate_number { my ($_n, $_key) = @_; _croak("$_tag: ($_key) is not valid") if (!defined $_n); $_n =~ s/K\z//i; $_n =~ s/M\z//i; if (!looks_like_number($_n) || int($_n) != $_n || $_n < 1) { _croak("$_tag: ($_key) is not valid"); } return; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Map - Parallel map model similar to the native map function =head1 VERSION This document describes MCE::Map version 1.810 =head1 SYNOPSIS ## Exports mce_map, mce_map_f, and mce_map_s use MCE::Map; ## Array or array_ref my @a = mce_map { $_ * $_ } 1..10000; my @b = mce_map { $_ * $_ } [ 1..10000 ]; ## File_path, glob_ref, or scalar_ref my @c = mce_map_f { chomp; $_ } "/path/to/file"; my @d = mce_map_f { chomp; $_ } $file_handle; my @e = mce_map_f { chomp; $_ } \$scalar; ## Sequence of numbers (begin, end [, step, format]) my @f = mce_map_s { $_ * $_ } 1, 10000, 5; my @g = mce_map_s { $_ * $_ } [ 1, 10000, 5 ]; my @h = mce_map_s { $_ * $_ } { begin => 1, end => 10000, step => 5, format => undef }; =head1 DESCRIPTION This module provides a parallel map implementation via Many-Core Engine. MCE incurs a small overhead due to passing of data. A fast code block will run faster natively. However, the overhead will likely diminish as the complexity increases for the code. my @m1 = map { $_ * $_ } 1..1000000; ## 0.127 secs my @m2 = mce_map { $_ * $_ } 1..1000000; ## 0.304 secs Chunking, enabled by default, greatly reduces the overhead behind the scene. The time for mce_map below also includes the time for data exchanges between the manager and worker processes. More parallelization will be seen when the code incurs additional CPU time. sub calc { sqrt $_ * sqrt $_ / 1.3 * 1.5 / 3.2 * 1.07 } my @m1 = map { calc } 1..1000000; ## 0.367 secs my @m2 = mce_map { calc } 1..1000000; ## 0.365 secs Even faster is mce_map_s; useful when input data is a range of numbers. Workers generate sequences mathematically among themselves without any interaction from the manager process. Two arguments are required for mce_map_s (begin, end). Step defaults to 1 if begin is smaller than end, otherwise -1. my @m3 = mce_map_s { calc } 1, 1000000; ## 0.270 secs Although this document is about MCE::Map, the L module can write results immediately without waiting for all chunks to complete. This is made possible by passing the reference to an array (in this case @m4 and @m5). use MCE::Stream; sub calc { sqrt $_ * sqrt $_ / 1.3 * 1.5 / 3.2 * 1.07 } my @m4; mce_stream \@m4, sub { calc }, 1..1000000; ## Completes in 0.272 secs. This is amazing considering the ## overhead for passing data between the manager and workers. my @m5; mce_stream_s \@m5, sub { calc }, 1, 1000000; ## Completed in 0.176 secs. Like with mce_map_s, specifying a ## sequence specification turns out to be faster due to lesser ## overhead for the manager process. =head1 OVERRIDING DEFAULTS The following list options which may be overridden when loading the module. use Sereal qw( encode_sereal decode_sereal ); use CBOR::XS qw( encode_cbor decode_cbor ); use JSON::XS qw( encode_json decode_json ); use MCE::Map max_workers => 4, # Default 'auto' chunk_size => 100, # Default 'auto' tmp_dir => "/path/to/app/tmp", # $MCE::Signal::tmp_dir freeze => \&encode_sereal, # \&Storable::freeze thaw => \&decode_sereal # \&Storable::thaw ; From MCE 1.8 onwards, Sereal 3.008+ is loaded automatically if available. Specify C 0> to use Storable instead. use MCE::Map Sereal => 0; =head1 CUSTOMIZING MCE =over 3 =item MCE::Map->init ( options ) =item MCE::Map::init { options } The init function accepts a hash of MCE options. The gather option, if specified, is ignored due to being used internally by the module. use MCE::Map; MCE::Map::init { chunk_size => 1, max_workers => 4, user_begin => sub { print "## ", MCE->wid, " started\n"; }, user_end => sub { print "## ", MCE->wid, " completed\n"; } }; my @a = mce_map { $_ * $_ } 1..100; print "\n", "@a", "\n"; -- Output ## 2 started ## 1 started ## 3 started ## 4 started ## 1 completed ## 4 completed ## 2 completed ## 3 completed 1 4 9 16 25 36 49 64 81 100 121 144 169 196 225 256 289 324 361 400 441 484 529 576 625 676 729 784 841 900 961 1024 1089 1156 1225 1296 1369 1444 1521 1600 1681 1764 1849 1936 2025 2116 2209 2304 2401 2500 2601 2704 2809 2916 3025 3136 3249 3364 3481 3600 3721 3844 3969 4096 4225 4356 4489 4624 4761 4900 5041 5184 5329 5476 5625 5776 5929 6084 6241 6400 6561 6724 6889 7056 7225 7396 7569 7744 7921 8100 8281 8464 8649 8836 9025 9216 9409 9604 9801 10000 =back =head1 API DOCUMENTATION =over 3 =item MCE::Map->run ( sub { code }, iterator ) =item mce_map { code } iterator An iterator reference can by specified for input_data. Iterators are described under "SYNTAX for INPUT_DATA" at L. my @a = mce_map { $_ * 2 } make_iterator(10, 30, 2); =item MCE::Map->run ( sub { code }, list ) =item mce_map { code } list Input data can be defined using a list. my @a = mce_map { $_ * 2 } 1..1000; my @b = mce_map { $_ * 2 } [ 1..1000 ]; =item MCE::Map->run_file ( sub { code }, file ) =item mce_map_f { code } file The fastest of these is the /path/to/file. Workers communicate the next offset position among themselves without any interaction from the manager process. my @c = mce_map_f { chomp; $_ . "\r\n" } "/path/to/file"; my @d = mce_map_f { chomp; $_ . "\r\n" } $file_handle; my @e = mce_map_f { chomp; $_ . "\r\n" } \$scalar; =item MCE::Map->run_seq ( sub { code }, $beg, $end [, $step, $fmt ] ) =item mce_map_s { code } $beg, $end [, $step, $fmt ] Sequence can be defined as a list, an array reference, or a hash reference. The functions require both begin and end values to run. Step and format are optional. The format is passed to sprintf (% may be omitted below). my ($beg, $end, $step, $fmt) = (10, 20, 0.1, "%4.1f"); my @f = mce_map_s { $_ } $beg, $end, $step, $fmt; my @g = mce_map_s { $_ } [ $beg, $end, $step, $fmt ]; my @h = mce_map_s { $_ } { begin => $beg, end => $end, step => $step, format => $fmt }; =back =head1 MANUAL SHUTDOWN =over 3 =item MCE::Map->finish =item MCE::Map::finish Workers remain persistent as much as possible after running. Shutdown occurs automatically when the script terminates. Call finish when workers are no longer needed. use MCE::Map; MCE::Map::init { chunk_size => 20, max_workers => 'auto' }; my @a = mce_map { ... } 1..100; MCE::Map::finish; =back =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.810/lib/MCE/Core/0000755000175000017500000000000013022753214013170 5ustar mariomarioMCE-1.810/lib/MCE/Core/Worker.pm0000644000175000017500000005035613022712366015013 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## Core methods for the worker process. ## ## This package provides main, loop, and relevant methods used internally by ## the worker process. ## ## There is no public API. ## ############################################################################### package MCE::Core::Worker; use strict; use warnings; our $VERSION = '1.810'; ## Items below are folded into MCE. package # hide from rpm MCE; no warnings qw( threads recursion uninitialized ); use bytes; ############################################################################### ## ---------------------------------------------------------------------------- ## Internal do, gather and send related functions for serializing data to ## destination. User functions for handling gather, queue or void. ## ############################################################################### { my ( $_dest, $_len, $_tag, $_task_id, $_user_func, $_val, $_wa, $_DAT_LOCK, $_DAT_W_SOCK, $_DAU_W_SOCK, $_chn, $_lock_chn, $_dat_ex, $_dat_un ); ## Create array structure containing various send functions. my @_dest_function = (); $_dest_function[SENDTO_FILEV2] = sub { ## Content >> File return unless (defined $_val); local $\ = undef if (defined $\); if (length ${ $_[0] }) { $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} OUTPUT_F_SND.$LF . $_chn.$LF; print {$_DAU_W_SOCK} $_val.$LF . length(${ $_[0] }).$LF, ${ $_[0] }; $_dat_un->() if $_lock_chn; } return; }; $_dest_function[SENDTO_FD] = sub { ## Content >> File descriptor return unless (defined $_val); local $\ = undef if (defined $\); if (length ${ $_[0] }) { $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} OUTPUT_D_SND.$LF . $_chn.$LF; print {$_DAU_W_SOCK} $_val.$LF . length(${ $_[0] }).$LF, ${ $_[0] }; $_dat_un->() if $_lock_chn; } return; }; $_dest_function[SENDTO_STDOUT] = sub { ## Content >> STDOUT local $\ = undef if (defined $\); if (length ${ $_[0] }) { $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} OUTPUT_O_SND.$LF . $_chn.$LF; print {$_DAU_W_SOCK} length(${ $_[0] }).$LF, ${ $_[0] }; $_dat_un->() if $_lock_chn; } return; }; $_dest_function[SENDTO_STDERR] = sub { ## Content >> STDERR local $\ = undef if (defined $\); if (length ${ $_[0] }) { $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} OUTPUT_E_SND.$LF . $_chn.$LF; print {$_DAU_W_SOCK} length(${ $_[0] }).$LF, ${ $_[0] }; $_dat_un->() if $_lock_chn; } return; }; ## ------------------------------------------------------------------------- sub _do_callback { my ($self, $_buf, $_aref); ($self, $_val, $_aref) = @_; unless (defined wantarray) { $_wa = WANTS_UNDEF; } elsif (wantarray) { $_wa = WANTS_ARRAY; } else { $_wa = WANTS_SCALAR; } ## Crossover: Send arguments if (scalar @{ $_aref } > 0) { ## Multiple Args >> Callback if (scalar @{ $_aref } > 1 || ref $_aref->[0]) { $_tag = OUTPUT_A_CBK; $_buf = $self->{freeze}($_aref); $_len = length $_buf; local $\ = undef if (defined $\); $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} $_tag.$LF . $_chn.$LF; print {$_DAU_W_SOCK} $_wa.$LF . $_val.$LF . $_len.$LF, $_buf; } else { ## Scalar >> Callback $_tag = OUTPUT_S_CBK; $_len = length $_aref->[0]; local $\ = undef if (defined $\); $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} $_tag.$LF . $_chn.$LF; print {$_DAU_W_SOCK} $_wa.$LF . $_val.$LF . $_len.$LF, $_aref->[0]; } } else { ## No Args >> Callback $_tag = OUTPUT_N_CBK; local $\ = undef if (defined $\); $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} $_tag.$LF . $_chn.$LF; print {$_DAU_W_SOCK} $_wa.$LF . $_val.$LF; } ## Crossover: Receive return value if ($_wa == WANTS_UNDEF) { $_dat_un->() if $_lock_chn; return; } elsif ($_wa == WANTS_ARRAY) { local $/ = $LF if (!$/ || $/ ne $LF); chomp($_len = <$_DAU_W_SOCK>); read($_DAU_W_SOCK, $_buf, $_len || 0); $_dat_un->() if $_lock_chn; return @{ $self->{thaw}($_buf) }; } else { local $/ = $LF if (!$/ || $/ ne $LF); chomp($_wa = <$_DAU_W_SOCK>); chomp($_len = <$_DAU_W_SOCK>); if ($_len >= 0) { read($_DAU_W_SOCK, $_buf, $_len || 0); $_dat_un->() if $_lock_chn; return $_buf if ($_wa == WANTS_SCALAR); return $self->{thaw}($_buf); } else { $_dat_un->() if $_lock_chn; return; } } } ## ------------------------------------------------------------------------- sub _do_gather { my $_buf; my ($self, $_aref) = @_; return unless (scalar @{ $_aref }); if (scalar @{ $_aref } > 1 || ref $_aref->[0]) { $_tag = OUTPUT_A_GTR; $_buf = $self->{freeze}($_aref); $_len = length $_buf; } else { $_tag = OUTPUT_S_GTR; if (defined $_aref->[0]) { $_len = length $_aref->[0]; local $\ = undef if (defined $\); $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} $_tag.$LF . $_chn.$LF; print {$_DAU_W_SOCK} $_task_id.$LF . $_len.$LF, $_aref->[0]; $_dat_un->() if $_lock_chn; return; } else { $_buf = ''; $_len = -1; } } local $\ = undef if (defined $\); $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} $_tag.$LF . $_chn.$LF; print {$_DAU_W_SOCK} $_task_id.$LF . $_len.$LF, $_buf; $_dat_un->() if $_lock_chn; return; } ## ------------------------------------------------------------------------- sub _do_send { my $_data_ref; my $self = shift; $_dest = shift; $_val = shift; if (scalar @_ > 1) { $_data_ref = \join('', @_); } elsif (my $_ref = ref $_[0]) { if ($_ref eq 'SCALAR') { $_data_ref = $_[0]; } elsif ($_ref eq 'ARRAY') { $_data_ref = \join('', @{ $_[0] }); } elsif ($_ref eq 'HASH') { $_data_ref = \join('', %{ $_[0] }); } else { $_data_ref = \join('', @_); } } else { $_data_ref = \$_[0]; } $_dest_function[$_dest]($_data_ref); return; } sub _do_send_glob { my ($self, $_glob, $_fd, $_data_ref) = @_; if ($self->{_wid} > 0) { if ($_fd == 1) { _do_send($self, SENDTO_STDOUT, undef, $_data_ref); } elsif ($_fd == 2) { _do_send($self, SENDTO_STDERR, undef, $_data_ref); } else { _do_send($self, SENDTO_FD, $_fd, $_data_ref); } } else { my $_fh = qualify_to_ref($_glob, caller); local $\ = undef if (defined $\); print {$_fh} ${ $_data_ref }; } return; } ## ------------------------------------------------------------------------- sub _do_send_init { my ($self) = @_; $_chn = $self->{_chn}; $_DAT_LOCK = $self->{_dat_lock}; $_DAT_W_SOCK = $self->{_dat_w_sock}->[0]; $_DAU_W_SOCK = $self->{_dat_w_sock}->[$_chn]; $_lock_chn = $self->{_lock_chn}; $_task_id = $self->{_task_id}; if ($_lock_chn) { $_dat_ex = sub { sysread ( $_DAT_LOCK->{_r_sock}, my $_b, 1 ) }; $_dat_un = sub { syswrite ( $_DAT_LOCK->{_w_sock}, '0' ) }; } { local ($|, $!); select(( select(*STDERR), $| = 1 )[0]) if defined(fileno *STDERR); select(( select(*STDOUT), $| = 1 )[0]) if defined(fileno *STDOUT); } return; } sub _do_send_clear { my ($self) = @_; $_dest = $_len = $_task_id = $_user_func = $_val = $_wa = undef; $_DAT_LOCK = $_DAT_W_SOCK = $_DAU_W_SOCK = $_chn = $_lock_chn = undef; $_dat_ex = $_dat_un = $_tag = undef; return; } ## ------------------------------------------------------------------------- sub _do_user_func { my ($self, $_chunk, $_chunk_id) = @_; $self->{_retry} = [ $_chunk, $_chunk_id, $self->{max_retries} ] if ($self->{max_retries}); $self->{_chunk_id} = $_chunk_id; $_user_func->($self, $_chunk, $_chunk_id); return; } sub _do_user_func_init { my ($self) = @_; $_user_func = $self->{user_func}; return; } } ############################################################################### ## ---------------------------------------------------------------------------- ## Worker process -- Do. ## ############################################################################### sub _worker_do { my ($self, $_params_ref) = @_; @_ = (); ## Set options. $self->{_abort_msg} = $_params_ref->{_abort_msg}; $self->{_run_mode} = $_params_ref->{_run_mode}; $self->{_single_dim} = $_params_ref->{_single_dim}; $self->{use_slurpio} = $_params_ref->{_use_slurpio}; $self->{parallel_io} = $_params_ref->{_parallel_io}; $self->{max_retries} = $_params_ref->{_max_retries}; $self->{RS} = $_params_ref->{_RS}; _do_user_func_init($self); ## Init local vars. my $_chn = $self->{_chn}; my $_DAT_LOCK = $self->{_dat_lock}; my $_DAT_W_SOCK = $self->{_dat_w_sock}->[0]; my $_DAU_W_SOCK = $self->{_dat_w_sock}->[$_chn]; my $_lock_chn = $self->{_lock_chn}; my $_run_mode = $self->{_run_mode}; my $_task_id = $self->{_task_id}; my $_task_name = $self->{task_name}; ## Do not override params if defined in user_tasks during instantiation. for my $_p (qw(bounds_only chunk_size interval sequence user_args)) { if (defined $_params_ref->{"_${_p}"}) { $self->{$_p} = $_params_ref->{"_${_p}"} unless (defined $self->{_task}->{$_p}); } } ## Assign user function. $self->{_wuf} = \&_do_user_func; ## Set time_block & start_time values for interval. if (defined $self->{interval}) { my $_i = $self->{interval}; my $_delay = $_i->{delay} * $_i->{max_nodes}; $self->{_i_app_tb} = $_delay * $self->{max_workers}; $self->{_i_app_st} = $_i->{_time} + ($_delay / $_i->{max_nodes} * $_i->{node_id}); $self->{_i_wrk_st} = ($self->{_task_wid} - 1) * $_delay + $self->{_i_app_st}; } ## Call user_begin if defined. if (defined $self->{user_begin}) { $self->{_chunk_id} = 0; $self->{user_begin}($self, $_task_id, $_task_name); $self->sync if ($_task_id == 0 && defined $self->{init_relay}); } ## Retry chunk if previous attempt died. if ($self->{_retry}) { $self->{_chunk_id} = $self->{_retry}->[1]; $self->{user_func}->($self, $self->{_retry}->[0], $self->{_retry}->[1]); delete $self->{_retry}; } ## Call worker function. if ($_run_mode eq 'sequence') { require MCE::Core::Input::Sequence unless (defined $MCE::Core::Input::Sequence::VERSION); _worker_sequence_queue($self); } elsif (defined $self->{_task}->{sequence}) { require MCE::Core::Input::Generator unless (defined $MCE::Core::Input::Generator::VERSION); _worker_sequence_generator($self); } elsif ($_run_mode eq 'array') { require MCE::Core::Input::Request unless (defined $MCE::Core::Input::Request::VERSION); _worker_request_chunk($self, REQUEST_ARRAY); } elsif ($_run_mode eq 'glob') { require MCE::Core::Input::Request unless (defined $MCE::Core::Input::Request::VERSION); _worker_request_chunk($self, REQUEST_GLOB); } elsif ($_run_mode eq 'iterator') { require MCE::Core::Input::Iterator unless (defined $MCE::Core::Input::Iterator::VERSION); _worker_user_iterator($self); } elsif ($_run_mode eq 'file') { require MCE::Core::Input::Handle unless (defined $MCE::Core::Input::Handle::VERSION); _worker_read_handle($self, READ_FILE, $_params_ref->{_input_file}); } elsif ($_run_mode eq 'memory') { require MCE::Core::Input::Handle unless (defined $MCE::Core::Input::Handle::VERSION); _worker_read_handle($self, READ_MEMORY, $self->{input_data}); } elsif (defined $self->{user_func}) { $self->{_chunk_id} = 0; $self->{user_func}->($self); } undef $self->{_next_jmp} if (defined $self->{_next_jmp}); undef $self->{_last_jmp} if (defined $self->{_last_jmp}); undef $self->{user_data} if (defined $self->{user_data}); ## Call user_end if defined. if (defined $self->{user_end}) { $self->{_chunk_id} = 0; $self->sync if ($_task_id == 0 && defined $self->{init_relay}); $self->{user_end}($self, $_task_id, $_task_name); } ## Check nested Hobo workers not yet joined. MCE::Hobo->finish('MCE') if $INC{'MCE/Hobo.pm'}; ## Notify the main process a worker has completed. local $\ = undef if (defined $\); $_DAT_LOCK->lock() if $_lock_chn; print {$_DAT_W_SOCK} OUTPUT_W_DNE.$LF . $_chn.$LF; print {$_DAU_W_SOCK} $_task_id.$LF; $_DAT_LOCK->unlock() if $_lock_chn; if ($^O eq 'MSWin32') { lock $self->{_run_lock}; } return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Worker process -- Loop. ## ############################################################################### sub _worker_loop { my ($self) = @_; @_ = (); my ($_response, $_len, $_buf, $_params_ref); my $_COM_LOCK = $self->{_com_lock}; my $_COM_W_SOCK = $self->{_com_w_sock}; my $_job_delay = $self->{job_delay}; my $_wid = $self->{_wid}; my $_com_ex = sub { sysread ( $_COM_LOCK->{_r_sock}, my $_b, 1 ) }; my $_com_un = sub { syswrite ( $_COM_LOCK->{_w_sock}, '0' ) }; if ( $^O eq 'MSWin32' ) { lock $MCE::_WIN_LOCK; } while (1) { { local $\ = undef; local $/ = $LF; $_com_ex->(); ## Wait for the next job request. $_response = <$_COM_W_SOCK>; print {$_COM_W_SOCK} $_wid.$LF; ## Return if instructed to exit. if ($_response eq "_exit\n") { $_com_un->(); return; } ## Process send request. if ($_response eq "_data\n") { chomp($_len = <$_COM_W_SOCK>); read $_COM_W_SOCK, $_buf, $_len; print {$_COM_W_SOCK} $_wid.$LF; $_com_un->(); $self->{user_data} = $self->{thaw}($_buf); undef $_buf; if (defined $_job_delay && $_job_delay > 0.0) { sleep $_job_delay * $_wid; } } ## Process normal request. elsif ($_response =~ /\d+/) { chomp($_len = <$_COM_W_SOCK>); read $_COM_W_SOCK, $_buf, $_len; print {$_COM_W_SOCK} $_wid.$LF; $_com_un->(); $_params_ref = $self->{thaw}($_buf); undef $_buf; } ## Leave loop if invalid response. else { last; } } ## Send request. _worker_do($self, {}), next if ($_response eq "_data\n"); ## Wait here until MCE completes job submission to all workers. sysread $self->{_bse_r_sock}, my($_b), 1; ## Normal request. if (defined $_job_delay && $_job_delay > 0.0) { sleep $_job_delay * $_wid; } _worker_do($self, $_params_ref); undef $_params_ref; } ## Notify the main process a worker has ended. The following is executed ## when an invalid reply was received above (not likely to occur). $_com_un->(); die "Worker ($self->{_wid}) has ended prematurely"; } ############################################################################### ## ---------------------------------------------------------------------------- ## Worker process -- Main. ## ############################################################################### sub _worker_main { my ( $self, $_wid, $_task, $_task_id, $_task_wid, $_params, $_plugin_worker_init ) = @_; @_ = (); if (exists $self->{input_data}) { my $_ref = ref $self->{input_data}; delete $self->{input_data} if ($_ref && $_ref ne 'SCALAR'); } $self->{_task_id} = (defined $_task_id ) ? $_task_id : 0; $self->{_task_wid} = (defined $_task_wid) ? $_task_wid : $_wid; $self->{_task} = $_task; $self->{_wid} = $_wid; ## Define exit pid and DIE handler. my $_use_threads = (defined $_task->{use_threads}) ? $_task->{use_threads} : $self->{use_threads}; if ($INC{'threads.pm'} && $_use_threads) { $self->{_exit_pid} = 'TID_' . threads->tid(); } else { $self->{_exit_pid} = 'PID_' . $$; } local $SIG{__DIE__} = sub { if (!defined $^S || $^S) { if ( ($INC{'threads.pm'} && threads->tid() != 0) || $ENV{'PERL_IPERL_RUNNING'} ) { # thread env or running inside IPerl, check stack trace my $_t = Carp::longmess(); $_t =~ s/\teval [^\n]+\n$//; if ( $_t =~ /^(?:[^\n]+\n){1,7}\teval / || $_t =~ /\n\teval [^\n]+\n\t(?:eval|Try)/ ) { CORE::die(@_); } } else { # normal env, trust $^S CORE::die(@_); } } local $SIG{__DIE__}; local $\ = undef; my $_die_msg = (defined $_[0]) ? $_[0] : ''; print {*STDERR} $_die_msg; $self->exit(255, $_die_msg, $self->{_chunk_id}); }; ## Use options from user_tasks if defined. $self->{max_workers} = $_task->{max_workers} if ($_task->{max_workers}); $self->{chunk_size} = $_task->{chunk_size} if ($_task->{chunk_size}); $self->{gather} = $_task->{gather} if ($_task->{gather}); $self->{interval} = $_task->{interval} if ($_task->{interval}); $self->{sequence} = $_task->{sequence} if ($_task->{sequence}); $self->{bounds_only} = $_task->{bounds_only} if ($_task->{bounds_only}); $self->{task_name} = $_task->{task_name} if ($_task->{task_name}); $self->{user_args} = $_task->{user_args} if ($_task->{user_args}); $self->{user_begin} = $_task->{user_begin} if ($_task->{user_begin}); $self->{user_func} = $_task->{user_func} if ($_task->{user_func}); $self->{user_end} = $_task->{user_end} if ($_task->{user_end}); ## Init runtime vars. Obtain handle to lock files. my $_mce_sid = $self->{_mce_sid}; my $_sess_dir = $self->{_sess_dir}; my $_chn; if (defined $_params && exists $_params->{_chn}) { $_chn = $self->{_chn} = delete $_params->{_chn}; } else { $_chn = $self->{_chn} = $_wid % $self->{_data_channels} + 1; } ## Choose locks for DATA channels. $self->{_com_lock} = $self->{'_mutex_0'}; $self->{_dat_lock} = $self->{'_mutex_'.$_chn} if ($self->{_lock_chn}); ## Delete attributes no longer required after being spawned. delete @{ $self }{ qw( flush_file flush_stderr flush_stdout stderr_file stdout_file on_post_exit on_post_run user_data user_error user_output _pids _state _status _thrs _tids ) }; ## Call MCE::Shared's init routine if present; enables parallel IPC. MCE::Shared::init($_wid) if ($INC{'MCE/Shared.pm'}); _do_send_init($self); ## Call module's worker_init routine for modules plugged into MCE. for my $_p (@{ $_plugin_worker_init }) { $_p->($self); } ## Begin processing if worker was added during processing. Otherwise, ## respond back to the main process if the last worker spawned. if (defined $_params) { _worker_do($self, $_params); undef $_params; } ## Enter worker loop. _worker_loop($self); ## Clear worker session. _do_send_clear($self); $self->{_com_lock} = undef; $self->{_dat_lock} = undef; return; } 1; MCE-1.810/lib/MCE/Core/Validation.pm0000644000175000017500000002031613022712364015623 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## Core validation methods for Many-Core Engine. ## ## This package provides validation methods used internally by the manager ## process. ## ## There is no public API. ## ############################################################################### package MCE::Core::Validation; use strict; use warnings; our $VERSION = '1.810'; ## Items below are folded into MCE. package # hide from rpm MCE; no warnings qw( threads recursion uninitialized ); ############################################################################### ## ---------------------------------------------------------------------------- ## Validation method (attributes allowed for top-level). ## ############################################################################### sub _validate_args { my $_s = $_[0]; @_ = (); my $_tag = 'MCE::_validate_args'; if (defined $_s->{input_data} && ref $_s->{input_data} eq '') { _croak("$_tag: ($_s->{input_data}) does not exist") unless (-e $_s->{input_data}); } _croak("$_tag: (use_slurpio) is not 0 or 1") if ($_s->{use_slurpio} && $_s->{use_slurpio} !~ /\A[01]\z/); _croak("$_tag: (parallel_io) is not 0 or 1") if ($_s->{parallel_io} && $_s->{parallel_io} !~ /\A[01]\z/); _croak("$_tag: (posix_exit) is not 0 or 1") if ($_s->{posix_exit} && $_s->{posix_exit} !~ /\A[01]\z/); _croak("$_tag: (job_delay) is not valid") if ($_s->{job_delay} && (!looks_like_number($_s->{job_delay}) || $_s->{job_delay} < 0)); _croak("$_tag: (spawn_delay) is not valid") if ($_s->{spawn_delay} && (!looks_like_number($_s->{spawn_delay}) || $_s->{spawn_delay} < 0)); _croak("$_tag: (submit_delay) is not valid") if ($_s->{submit_delay} && (!looks_like_number($_s->{submit_delay}) || $_s->{submit_delay} < 0)); _croak("$_tag: (freeze) is not a CODE reference") if ($_s->{freeze} && ref $_s->{freeze} ne 'CODE'); _croak("$_tag: (thaw) is not a CODE reference") if ($_s->{thaw} && ref $_s->{thaw} ne 'CODE'); _croak("$_tag: (on_post_exit) is not a CODE reference") if ($_s->{on_post_exit} && ref $_s->{on_post_exit} ne 'CODE'); _croak("$_tag: (on_post_run) is not a CODE reference") if ($_s->{on_post_run} && ref $_s->{on_post_run} ne 'CODE'); _croak("$_tag: (user_error) is not a CODE reference") if ($_s->{user_error} && ref $_s->{user_error} ne 'CODE'); _croak("$_tag: (user_output) is not a CODE reference") if ($_s->{user_output} && ref $_s->{user_output} ne 'CODE'); _croak("$_tag: (flush_file) is not 0 or 1") if ($_s->{flush_file} && $_s->{flush_file} !~ /\A[01]\z/); _croak("$_tag: (flush_stderr) is not 0 or 1") if ($_s->{flush_stderr} && $_s->{flush_stderr} !~ /\A[01]\z/); _croak("$_tag: (flush_stdout) is not 0 or 1") if ($_s->{flush_stdout} && $_s->{flush_stdout} !~ /\A[01]\z/); _croak("$_tag: (loop_timeout) is not valid") if ($_s->{loop_timeout} && !looks_like_number($_s->{loop_timeout})); _validate_args_s($_s); if (defined $_s->{user_tasks}) { for my $_t (@{ $_s->{user_tasks} }) { _validate_args_s($_s, $_t); _croak("$_tag: (task_end) is not a CODE reference") if ($_t->{task_end} && ref $_t->{task_end} ne 'CODE'); } } return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Validation method (top-level and sub-tasks). ## ############################################################################### sub _validate_args_s { my $self = $_[0]; my $_s = $_[1] || $self; @_ = (); my $_tag = 'MCE::_validate_args_s'; if (defined $_s->{max_workers}) { $_s->{max_workers} = _parse_max_workers($_s->{max_workers}); _croak("$_tag: (max_workers) is not valid") if ($_s->{max_workers} !~ /\A\d+\z/); } if (defined $_s->{chunk_size}) { if ($_s->{chunk_size} =~ /([0-9\.]+)K\z/i) { $_s->{chunk_size} = int($1 * 1024 + 0.5); } elsif ($_s->{chunk_size} =~ /([0-9\.]+)M\z/i) { $_s->{chunk_size} = int($1 * 1024 * 1024 + 0.5); } _croak("$_tag: (chunk_size) is not valid") if ($_s->{chunk_size} !~ /\A\d+\z/ or $_s->{chunk_size} == 0); $_s->{chunk_size} = MAX_CHUNK_SIZE if ($_s->{chunk_size} > MAX_CHUNK_SIZE); } _croak("$_tag: (RS) is not valid") if ($_s->{RS} && ref $_s->{RS} ne ''); _croak("$_tag: (max_retries) is not valid") if ($_s->{max_retries} && $_s->{max_retries} !~ /\A\d+\z/); _croak("$_tag: (use_threads) is not 0 or 1") if ($_s->{use_threads} && $_s->{use_threads} !~ /\A[01]\z/); _croak("$_tag: (user_begin) is not a CODE reference") if ($_s->{user_begin} && ref $_s->{user_begin} ne 'CODE'); _croak("$_tag: (user_func) is not a CODE reference") if ($_s->{user_func} && ref $_s->{user_func} ne 'CODE'); _croak("$_tag: (user_end) is not a CODE reference") if ($_s->{user_end} && ref $_s->{user_end} ne 'CODE'); if (defined $_s->{gather}) { my $_ref = ref $_s->{gather}; _croak("$_tag: (gather) is not a valid reference") if ( $_ref ne 'MCE::Queue' && $_ref ne 'Thread::Queue' && $_ref ne 'ARRAY' && $_ref ne 'HASH' && $_ref ne 'CODE' ); } if (defined $_s->{sequence}) { my $_seq = $_s->{sequence}; if (ref $_seq eq 'ARRAY') { my ($_begin, $_end, $_step, $_fmt) = @{ $_seq }; $_seq = { begin => $_begin, end => $_end, step => $_step, format => $_fmt }; } else { _croak("$_tag: (sequence) is not a HASH or ARRAY reference") if (ref $_seq ne 'HASH'); } _croak("$_tag: (begin) is not defined for sequence") unless (defined $_seq->{begin}); _croak("$_tag: (end) is not defined for sequence") unless (defined $_seq->{end}); for my $_p (qw(begin end step)) { _croak("$_tag: ($_p) is not valid for sequence") if (defined $_seq->{$_p} && !looks_like_number($_seq->{$_p})); } unless (defined $_seq->{step}) { $_seq->{step} = ($_seq->{begin} < $_seq->{end}) ? 1 : -1; if (ref $_s->{sequence} eq 'ARRAY') { $_s->{sequence}->[2] = $_seq->{step}; } } if ( ($_seq->{step} < 0 && $_seq->{begin} < $_seq->{end}) || ($_seq->{step} > 0 && $_seq->{begin} > $_seq->{end}) || ($_seq->{step} == 0) ) { _croak("$_tag: impossible (step size) for sequence"); } } if (defined $_s->{interval}) { if (ref $_s->{interval} eq '') { $_s->{interval} = { delay => $_s->{interval} }; } my $_i = $_s->{interval}; _croak("$_tag: (interval) is not a HASH reference") if (ref $_i ne 'HASH'); _croak("$_tag: (delay) is not defined for interval") unless (defined $_i->{delay}); _croak("$_tag: (delay) is not valid for interval") if (!looks_like_number($_i->{delay}) || $_i->{delay} < 0); for my $_p (qw(max_nodes node_id)) { _croak("$_tag: ($_p) is not valid for interval") if (defined $_i->{$_p} && ( !looks_like_number($_i->{$_p}) || int($_i->{$_p}) != $_i->{$_p} || $_i->{$_p} < 1 )); } $_i->{max_nodes} = 1 unless (exists $_i->{max_nodes}); $_i->{node_id} = 1 unless (exists $_i->{node_id}); $_i->{_time} = time; } return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Validation method (run state). ## ############################################################################### sub _validate_runstate { my $self = $_[0]; my $_tag = $_[1]; @_ = (); _croak("$_tag: method is not allowed by the worker process") if ($self->{_wid}); _croak("$_tag: method is not allowed while processing") if ($self->{_send_cnt}); _croak("$_tag: method is not allowed while running") if ($self->{_total_running}); return; } 1; MCE-1.810/lib/MCE/Core/Input/0000755000175000017500000000000013022753214014267 5ustar mariomarioMCE-1.810/lib/MCE/Core/Input/Generator.pm0000644000175000017500000001353413022712352016557 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## Sequence of numbers (for task_id > 0). ## ## This package provides a sequence of numbers used internally by the worker ## process. Distribution is divided equally among workers. This allows sequence ## to be configured independently among multiple user tasks. ## ## There is no public API. ## ############################################################################### package MCE::Core::Input::Generator; use strict; use warnings; our $VERSION = '1.810'; ## Items below are folded into MCE. package # hide from rpm MCE; no warnings qw( threads recursion uninitialized ); ############################################################################### ## ---------------------------------------------------------------------------- ## Worker process -- Sequence Generator (equal distribution among workers). ## ############################################################################### sub _worker_sequence_generator { my ($self) = @_; @_ = (); _croak('MCE::_worker_sequence_generator: (user_func) is not specified') unless (defined $self->{user_func}); my $_bounds_only = $self->{bounds_only} || 0; my $_max_workers = $self->{max_workers}; my $_chunk_size = $self->{chunk_size}; my $_wuf = $self->{_wuf}; my ($_begin, $_end, $_step, $_fmt); if (ref $self->{sequence} eq 'ARRAY') { ($_begin, $_end, $_step, $_fmt) = @{ $self->{sequence} }; } else { $_begin = $self->{sequence}->{begin}; $_end = $self->{sequence}->{end}; $_step = $self->{sequence}->{step}; $_fmt = $self->{sequence}->{format}; } my $_wid = $self->{_task_wid} || $self->{_wid}; my $_next = ($_wid - 1) * $_chunk_size * $_step + $_begin; my $_chunk_id = $_wid; $_fmt =~ s/%// if (defined $_fmt); ## ------------------------------------------------------------------------- local $_; $self->{_last_jmp} = sub { goto _WORKER_SEQ_GEN__LAST; }; if ($_begin == $_end) { ## Identical, yes. if ($_wid == 1) { $self->{_next_jmp} = sub { goto _WORKER_SEQ_GEN__LAST; }; $_ = (defined $_fmt) ? sprintf("%$_fmt", $_next) : $_next; if ($_chunk_size > 1 || $_bounds_only) { $_ = ($_bounds_only) ? [ $_, $_ ] : [ $_ ]; } $_wuf->($self, $_, $_chunk_id); } } elsif ($_chunk_size == 1) { ## Chunking, no. $self->{_next_jmp} = sub { goto _WORKER_SEQ_GEN__NEXT_A; }; my $_flag = ($_begin < $_end); while (1) { return if ( $_flag && $_next > $_end); return if (!$_flag && $_next < $_end); $_ = (defined $_fmt) ? sprintf("%$_fmt", $_next) : $_next; $_ = [ $_, $_ ] if ($_bounds_only); $_wuf->($self, $_, $_chunk_id); _WORKER_SEQ_GEN__NEXT_A: $_chunk_id += $_max_workers; $_next = ($_chunk_id - 1) * $_step + $_begin; } } else { ## Chunking, yes. $self->{_next_jmp} = sub { goto _WORKER_SEQ_GEN__NEXT_B; }; while (1) { my @_n = (); my $_n_begin = $_next; ## ------------------------------------------------------------------- if ($_bounds_only) { my ($_tmp_b, $_tmp_e) = ($_next); if ($_begin < $_end) { if ($_step * ($_chunk_size - 1) + $_n_begin <= $_end) { $_tmp_e = $_step * ($_chunk_size - 1) + $_n_begin; } else { for my $_i (1 .. $_chunk_size) { last if ($_next > $_end); $_tmp_e = $_next; $_next = $_step * $_i + $_n_begin; } } } else { if ($_step * ($_chunk_size - 1) + $_n_begin >= $_end) { $_tmp_e = $_step * ($_chunk_size - 1) + $_n_begin; } else { for my $_i (1 .. $_chunk_size) { last if ($_next < $_end); $_tmp_e = $_next; $_next = $_step * $_i + $_n_begin; } } } return unless (defined $_tmp_e); @_n = (defined $_fmt) ? ( sprintf("%$_fmt",$_tmp_b), sprintf("%$_fmt",$_tmp_e) ) : ( $_tmp_b, $_tmp_e ); } ## ------------------------------------------------------------------- else { if ($_begin < $_end) { if (!defined $_fmt && $_step == 1) { @_n = ($_next + $_chunk_size <= $_end) ? ($_next .. $_next + $_chunk_size - 1) : ($_next .. $_end); } else { for my $_i (1 .. $_chunk_size) { last if ($_next > $_end); push @_n, (defined $_fmt) ? sprintf("%$_fmt", $_next) : $_next; $_next = $_step * $_i + $_n_begin; } } } else { for my $_i (1 .. $_chunk_size) { last if ($_next < $_end); push @_n, (defined $_fmt) ? sprintf("%$_fmt", $_next) : $_next; $_next = $_step * $_i + $_n_begin; } } return unless (scalar @_n); } ## ------------------------------------------------------------------- $_ = \@_n; $_wuf->($self, \@_n, $_chunk_id); _WORKER_SEQ_GEN__NEXT_B: $_chunk_id += $_max_workers; $_next = ($_chunk_id - 1) * $_chunk_size * $_step + $_begin; } } _WORKER_SEQ_GEN__LAST: return; } 1; MCE-1.810/lib/MCE/Core/Input/Iterator.pm0000644000175000017500000000552713022712355016430 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## Iterator reader. ## ## This package, used interally by the worker process, provides support for ## user specified iterators assigned to input_data. ## ## There is no public API. ## ############################################################################### package MCE::Core::Input::Iterator; use strict; use warnings; our $VERSION = '1.810'; ## Items below are folded into MCE. package # hide from rpm MCE; no warnings qw( threads recursion uninitialized ); use bytes; ############################################################################### ## ---------------------------------------------------------------------------- ## Worker process -- User Iterator. ## ############################################################################### sub _worker_user_iterator { my ($self) = @_; @_ = (); _croak('MCE::_worker_user_iterator: (user_func) is not specified') unless (defined $self->{user_func}); my $_chn = $self->{_chn}; my $_DAT_LOCK = $self->{_dat_lock}; my $_DAT_W_SOCK = $self->{_dat_w_sock}->[0]; my $_DAU_W_SOCK = $self->{_dat_w_sock}->[$_chn]; my $_lock_chn = $self->{_lock_chn}; my $_chunk_size = $self->{chunk_size}; my $_I_FLG = (!$/ || $/ ne $LF); my $_wuf = $self->{_wuf}; my ($_dat_ex, $_dat_un); if ($_lock_chn) { $_dat_ex = sub { sysread ( $_DAT_LOCK->{_r_sock}, my $_b, 1 ) }; $_dat_un = sub { syswrite ( $_DAT_LOCK->{_w_sock}, '0' ) }; } my ($_chunk_id, $_len, $_is_ref); ## ------------------------------------------------------------------------- $self->{_next_jmp} = sub { goto _WORKER_USER_ITERATOR__NEXT; }; $self->{_last_jmp} = sub { goto _WORKER_USER_ITERATOR__LAST; }; local $_; _WORKER_USER_ITERATOR__NEXT: while (1) { undef $_ if (length > MAX_CHUNK_SIZE); $_ = ''; ## Obtain the next chunk of data. { local $\ = undef if (defined $\); local $/ = $LF if ($_I_FLG); $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} OUTPUT_U_ITR . $LF . $_chn . $LF; chomp($_len = <$_DAU_W_SOCK>); if ($_len < 0) { $_dat_un->() if $_lock_chn; return; } $_is_ref = chop $_len; chomp($_chunk_id = <$_DAU_W_SOCK>); read $_DAU_W_SOCK, $_, $_len; $_dat_un->() if $_lock_chn; } ## Call user function. if ($_is_ref) { my $_chunk_ref = $self->{thaw}($_); undef $_; $_ = ($_chunk_size == 1) ? $_chunk_ref->[0] : $_chunk_ref; $_wuf->($self, $_chunk_ref, $_chunk_id); } else { $_wuf->($self, [ $_ ], $_chunk_id); } } _WORKER_USER_ITERATOR__LAST: return; } 1; MCE-1.810/lib/MCE/Core/Input/Sequence.pm0000644000175000017500000001266513022712360016404 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## Sequence of numbers (for task_id == 0). ## ## This package provides a sequence of numbers used internally by the worker ## process. Distribution follows a bank-queuing model. ## ## There is no public API. ## ############################################################################### package MCE::Core::Input::Sequence; use strict; use warnings; our $VERSION = '1.810'; ## Items below are folded into MCE. package # hide from rpm MCE; no warnings qw( threads recursion uninitialized ); my $_que_read_size = $MCE::_que_read_size; my $_que_template = $MCE::_que_template; ############################################################################### ## ---------------------------------------------------------------------------- ## Worker process -- Sequence Queue (distribution via bank queuing model). ## ############################################################################### sub _worker_sequence_queue { my ($self) = @_; @_ = (); _croak('MCE::_worker_sequence_queue: (user_func) is not specified') unless (defined $self->{user_func}); my $_QUE_R_SOCK = $self->{_que_r_sock}; my $_QUE_W_SOCK = $self->{_que_w_sock}; my $_bounds_only = $self->{bounds_only} || 0; my $_chunk_size = $self->{chunk_size}; my $_wuf = $self->{_wuf}; my ($_next, $_chunk_id, $_seq_n, $_begin, $_end, $_step, $_fmt); my ($_abort, $_offset); if (ref $self->{sequence} eq 'ARRAY') { ($_begin, $_end, $_step, $_fmt) = @{ $self->{sequence} }; } else { $_begin = $self->{sequence}->{begin}; $_end = $self->{sequence}->{end}; $_step = $self->{sequence}->{step}; $_fmt = $self->{sequence}->{format}; } $_abort = $self->{_abort_msg}; $_chunk_id = $_offset = 0; $_fmt =~ s/%// if (defined $_fmt); ## ------------------------------------------------------------------------- $self->{_next_jmp} = sub { goto _WORKER_SEQUENCE__NEXT; }; $self->{_last_jmp} = sub { goto _WORKER_SEQUENCE__LAST; }; local $_; _WORKER_SEQUENCE__NEXT: while (1) { ## Obtain the next chunk_id and sequence number. sysread $_QUE_R_SOCK, $_next, $_que_read_size; ($_chunk_id, $_offset) = unpack($_que_template, $_next); if ($_offset >= $_abort) { syswrite $_QUE_W_SOCK, pack($_que_template, 0, $_offset); return; } syswrite $_QUE_W_SOCK, pack($_que_template, $_chunk_id + 1, $_offset + 1); $_chunk_id++; ## Call user function. if ($_chunk_size == 1) { $_ = $_offset * $_step + $_begin; $_ = sprintf("%$_fmt", $_) if (defined $_fmt); $_ = [ $_, $_ ] if ($_bounds_only); $_wuf->($self, $_, $_chunk_id); } else { my $_n_begin = ($_offset * $_chunk_size) * $_step + $_begin; my @_n = (); $_seq_n = $_n_begin; ## ------------------------------------------------------------------- if ($_bounds_only) { my ($_tmp_b, $_tmp_e) = ($_seq_n); if ($_begin < $_end) { if ($_step * ($_chunk_size - 1) + $_n_begin <= $_end) { $_tmp_e = $_step * ($_chunk_size - 1) + $_n_begin; } else { for my $_i (1 .. $_chunk_size) { last if ($_seq_n > $_end); $_tmp_e = $_seq_n; $_seq_n = $_step * $_i + $_n_begin; } } } else { if ($_step * ($_chunk_size - 1) + $_n_begin >= $_end) { $_tmp_e = $_step * ($_chunk_size - 1) + $_n_begin; } else { for my $_i (1 .. $_chunk_size) { last if ($_seq_n < $_end); $_tmp_e = $_seq_n; $_seq_n = $_step * $_i + $_n_begin; } } } @_n = (defined $_fmt) ? ( sprintf("%$_fmt",$_tmp_b), sprintf("%$_fmt",$_tmp_e) ) : ( $_tmp_b, $_tmp_e ); } ## ------------------------------------------------------------------- else { if ($_begin < $_end) { if (!defined $_fmt && $_step == 1) { $_ = ($_seq_n + $_chunk_size <= $_end) ? [ $_seq_n .. $_seq_n + $_chunk_size - 1 ] : [ $_seq_n .. $_end ]; $_wuf->($self, $_, $_chunk_id); next; } else { for my $_i (1 .. $_chunk_size) { last if ($_seq_n > $_end); push @_n, (defined $_fmt) ? sprintf("%$_fmt", $_seq_n) : $_seq_n; $_seq_n = $_step * $_i + $_n_begin; } } } else { for my $_i (1 .. $_chunk_size) { last if ($_seq_n < $_end); push @_n, (defined $_fmt) ? sprintf("%$_fmt", $_seq_n) : $_seq_n; $_seq_n = $_step * $_i + $_n_begin; } } } ## ------------------------------------------------------------------- $_ = \@_n; $_wuf->($self, \@_n, $_chunk_id); } } _WORKER_SEQUENCE__LAST: return; } 1; MCE-1.810/lib/MCE/Core/Input/Handle.pm0000644000175000017500000001551513022712354016027 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## File_path and Scalar_ref input reader. ## ## This package provides the read handle method used internally by the worker ## process. Distribution follows a bank-queuing model. ## ## There is no public API. ## ############################################################################### package MCE::Core::Input::Handle; use strict; use warnings; our $VERSION = '1.810'; ## Items below are folded into MCE. package # hide from rpm MCE; no warnings qw( threads recursion uninitialized ); use Fcntl qw( SEEK_CUR ); use bytes; my $_que_read_size = $MCE::_que_read_size; my $_que_template = $MCE::_que_template; ############################################################################### ## ---------------------------------------------------------------------------- ## Worker process -- Read handle. ## ############################################################################### sub _systell { sysseek($_[0], 0, SEEK_CUR); } sub _worker_read_handle { my ($self, $_proc_type, $_input_data) = @_; @_ = (); _croak('MCE::_worker_read_handle: (user_func) is not specified') unless (defined $self->{user_func}); my $_QUE_R_SOCK = $self->{_que_r_sock}; my $_QUE_W_SOCK = $self->{_que_w_sock}; my $_chunk_size = $self->{chunk_size}; my $_use_slurpio = $self->{use_slurpio}; my $_parallel_io = $self->{parallel_io}; my $_RS = $self->{RS} || $/; my $_RS_FLG = (!$_RS || $_RS ne $LF); my $_wuf = $self->{_wuf}; my ($_data_size, $_next, $_chunk_id, $_offset_pos, $_IN_FILE, $_tmp_cs); my ($_chop_len, $_chop_str, $_p); if (length $_RS > 1 && substr($_RS, 0, 1) eq "\n") { $_chop_str = substr($_RS, 1); $_chop_len = length $_chop_str; } else { $_chop_str = ''; $_chop_len = 0; } $_data_size = ($_proc_type == READ_MEMORY) ? length ${ $_input_data } : -s $_input_data; $_chunk_id = $_offset_pos = 0; open $_IN_FILE, '<', $_input_data or die "$_input_data: $!\n"; binmode $_IN_FILE; ## ------------------------------------------------------------------------- $self->{_next_jmp} = sub { goto _WORKER_READ_HANDLE__NEXT; }; $self->{_last_jmp} = sub { goto _WORKER_READ_HANDLE__LAST; }; local $_; _WORKER_READ_HANDLE__NEXT: while (1) { my @_recs; undef $_ if (length > MAX_CHUNK_SIZE); $_ = ''; ## Obtain the next chunk_id and offset position. sysread $_QUE_R_SOCK, $_next, $_que_read_size; ($_chunk_id, $_offset_pos) = unpack($_que_template, $_next); if ($_offset_pos >= $_data_size) { syswrite $_QUE_W_SOCK, pack($_que_template, 0, $_offset_pos); close $_IN_FILE; undef $_IN_FILE; return; } if (++$_chunk_id > 1 && $_chop_len) { $_p = $_chop_len; $_ = $_chop_str; } else { $_p = 0; } ## Read data. if ($_chunk_size <= MAX_RECS_SIZE) { # One or many records. local $/ = $_RS if ($_RS_FLG); seek $_IN_FILE, $_offset_pos, 0; if ($_chunk_size == 1) { if ($_p) { $_ .= <$_IN_FILE>; } else { $_ = <$_IN_FILE>; } } else { if ($_use_slurpio) { for my $i (0 .. $_chunk_size - 1) { $_ .= <$_IN_FILE>; } } else { if ($_chop_len) { $_recs[0] = ($_chunk_id > 1) ? $_chop_str : ''; $_recs[0] .= <$_IN_FILE>; for my $i (1 .. $_chunk_size - 1) { $_recs[$i] = $_chop_str; $_recs[$i] .= <$_IN_FILE>; if (length $_recs[$i] == $_chop_len) { delete $_recs[$i]; last; } } } else { for my $i (0 .. $_chunk_size - 1) { $_recs[$i] = <$_IN_FILE>; unless (defined $_recs[$i]) { delete $_recs[$i]; last; } } } } } syswrite $_QUE_W_SOCK, pack($_que_template, $_chunk_id, tell $_IN_FILE); } else { # Large chunk. local $/ = $_RS if ($_RS_FLG); if ($_parallel_io && ! $_RS_FLG) { syswrite $_QUE_W_SOCK, pack($_que_template, $_chunk_id, $_offset_pos + $_chunk_size); $_tmp_cs = $_chunk_size; seek $_IN_FILE, $_offset_pos, 0; if ($_offset_pos) { $_tmp_cs -= length <$_IN_FILE> || 0; } if ($_proc_type == READ_FILE) { sysseek $_IN_FILE, tell( $_IN_FILE ), 0; sysread $_IN_FILE, $_, $_tmp_cs, $_p; seek $_IN_FILE, _systell( $_IN_FILE ), 0; } else { read $_IN_FILE, $_, $_tmp_cs, $_p; } $_ .= <$_IN_FILE>; } else { if ($_proc_type == READ_FILE) { sysseek $_IN_FILE, $_offset_pos, 0; sysread $_IN_FILE, $_, $_chunk_size, $_p; seek $_IN_FILE, _systell( $_IN_FILE ), 0; } else { seek $_IN_FILE, $_offset_pos, 0; read $_IN_FILE, $_, $_chunk_size, $_p; } $_ .= <$_IN_FILE>; syswrite $_QUE_W_SOCK, pack($_que_template, $_chunk_id, tell $_IN_FILE); } } ## Call user function. if ($_use_slurpio) { if ($_chop_len && substr($_, -$_chop_len) eq $_chop_str) { substr($_, -$_chop_len, $_chop_len, ''); } local $_ = \$_; $_wuf->($self, $_, $_chunk_id); } else { if ($_chunk_size == 1) { if ($_chop_len && substr($_, -$_chop_len) eq $_chop_str) { substr($_, -$_chop_len, $_chop_len, ''); } $_wuf->($self, [ $_ ], $_chunk_id); } else { if ($_chunk_size > MAX_RECS_SIZE) { local $/ = $_RS if ($_RS_FLG); _sync_buffer_to_array(\$_, \@_recs, $_chop_str); undef $_; } if ($_chop_len) { for my $i (0 .. @_recs - 1) { if (substr($_recs[$i], -$_chop_len) eq $_chop_str) { substr($_recs[$i], -$_chop_len, $_chop_len, ''); } } } local $_ = \@_recs; $_wuf->($self, \@_recs, $_chunk_id); } } } _WORKER_READ_HANDLE__LAST: close $_IN_FILE; undef $_IN_FILE; return; } 1; MCE-1.810/lib/MCE/Core/Input/Request.pm0000644000175000017500000001145213022712357016263 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## Array_ref and Glob_ref input reader. ## ## This package provides the request chunk method used internally by the worker ## process. Distribution follows a bank-queuing model. ## ## There is no public API. ## ############################################################################### package MCE::Core::Input::Request; use strict; use warnings; our $VERSION = '1.810'; ## Items below are folded into MCE. package # hide from rpm MCE; no warnings qw( threads recursion uninitialized ); use bytes; ############################################################################### ## ---------------------------------------------------------------------------- ## Worker process -- Request chunk. ## ############################################################################### sub _worker_request_chunk { my ($self, $_proc_type) = @_; @_ = (); _croak('MCE::_worker_request_chunk: (user_func) is not specified') unless (defined $self->{user_func}); my $_chn = $self->{_chn}; my $_DAT_LOCK = $self->{_dat_lock}; my $_DAT_W_SOCK = $self->{_dat_w_sock}->[0]; my $_DAU_W_SOCK = $self->{_dat_w_sock}->[$_chn]; my $_lock_chn = $self->{_lock_chn}; my $_single_dim = $self->{_single_dim}; my $_chunk_size = $self->{chunk_size}; my $_use_slurpio = $self->{use_slurpio}; my $_RS = $self->{RS} || $/; my $_RS_FLG = (!$_RS || $_RS ne $LF); my $_I_FLG = (!$/ || $/ ne $LF); my $_wuf = $self->{_wuf}; my ($_dat_ex, $_dat_un); if ($_lock_chn) { $_dat_ex = sub { sysread ( $_DAT_LOCK->{_r_sock}, my $_b, 1 ) }; $_dat_un = sub { syswrite ( $_DAT_LOCK->{_w_sock}, '0' ) }; } my ($_chunk_id, $_len, $_output_tag); my ($_chop_len, $_chop_str, $_p); if ($_proc_type == REQUEST_ARRAY) { $_output_tag = OUTPUT_A_ARY; $_chop_len = 0; } else { $_output_tag = OUTPUT_S_GLB; if (length $_RS > 1 && substr($_RS, 0, 1) eq "\n") { $_chop_str = substr($_RS, 1); $_chop_len = length $_chop_str; } else { $_chop_str = ''; $_chop_len = 0; } } ## ------------------------------------------------------------------------- $self->{_next_jmp} = sub { goto _WORKER_REQUEST_CHUNK__NEXT; }; $self->{_last_jmp} = sub { goto _WORKER_REQUEST_CHUNK__LAST; }; local $_; _WORKER_REQUEST_CHUNK__NEXT: while (1) { undef $_ if (length > MAX_CHUNK_SIZE); $_ = ''; ## Obtain the next chunk of data. { local $\ = undef if (defined $\); local $/ = $LF if ($_I_FLG); $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} $_output_tag . $LF . $_chn . $LF; chomp($_len = <$_DAU_W_SOCK>); unless ($_len) { $_dat_un->() if $_lock_chn; return; } chomp($_chunk_id = <$_DAU_W_SOCK>); if ($_chunk_id > 1 && $_chop_len) { $_p = $_chop_len; $_ = $_chop_str; } else { $_p = 0; } read $_DAU_W_SOCK, $_, $_len, $_p; $_dat_un->() if $_lock_chn; } ## Call user function. if ($_proc_type == REQUEST_ARRAY) { if ($_single_dim && $_chunk_size == 1) { $_wuf->($self, [ $_ ], $_chunk_id); } else { my $_chunk_ref = $self->{thaw}($_); undef $_; $_ = ($_chunk_size == 1) ? $_chunk_ref->[0] : $_chunk_ref; $_wuf->($self, $_chunk_ref, $_chunk_id); } } else { if ($_use_slurpio) { if ($_chop_len && substr($_, -$_chop_len) eq $_chop_str) { substr($_, -$_chop_len, $_chop_len, ''); } local $_ = \$_; $_wuf->($self, $_, $_chunk_id); } else { if ($_chunk_size == 1) { if ($_chop_len && substr($_, -$_chop_len) eq $_chop_str) { substr($_, -$_chop_len, $_chop_len, ''); } $_wuf->($self, [ $_ ], $_chunk_id); } else { my @_recs; { local $/ = $_RS if ($_RS_FLG); _sync_buffer_to_array(\$_, \@_recs, $_chop_str); undef $_; } if ($_chop_len) { for my $i (0 .. @_recs - 1) { if (substr($_recs[$i], -$_chop_len) eq $_chop_str) { substr($_recs[$i], -$_chop_len, $_chop_len, ''); } } } local $_ = \@_recs; $_wuf->($self, \@_recs, $_chunk_id); } } } } _WORKER_REQUEST_CHUNK__LAST: return; } 1; MCE-1.810/lib/MCE/Core/Manager.pm0000644000175000017500000006571513022712362015115 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## Core methods for the manager process. ## ## This package provides the loop and relevant methods used internally by the ## manager process. ## ## There is no public API. ## ############################################################################### package MCE::Core::Manager; use strict; use warnings; our $VERSION = '1.810'; ## no critic (BuiltinFunctions::ProhibitStringyEval) ## no critic (TestingAndDebugging::ProhibitNoStrict) ## Items below are folded into MCE. package # hide from rpm MCE; no warnings qw( threads recursion uninitialized ); ## POSIX.pm is a big module. The following constant covers most platforms. use constant { _WNOHANG => $^O eq 'solaris' ? 64 : 1 }; use bytes; ############################################################################### ## ---------------------------------------------------------------------------- ## Call on task_end after task completion. ## ############################################################################### sub _task_end { my ($self, $_task_id) = @_; @_ = (); if (defined $self->{user_tasks}) { my $_task_end = (exists $self->{user_tasks}->[$_task_id]->{task_end}) ? $self->{user_tasks}->[$_task_id]->{task_end} : $self->{task_end}; if (defined $_task_end) { my $_task_name = (exists $self->{user_tasks}->[$_task_id]->{task_name}) ? $self->{user_tasks}->[$_task_id]->{task_name} : $self->{task_name}; $_task_end->($self, $_task_id, $_task_name); } } return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Process output. ## ## Awaits and processes events from workers. The sendto/do methods tag the ## output accordingly. The hash structure below is key-driven. ## ############################################################################### sub _output_loop { my ( $self, $_input_data, $_input_glob, $_plugin_function, $_plugin_loop_begin, $_plugin_loop_end ) = @_; @_ = (); my ( $_aborted, $_eof_flag, $_max_retries, $_syn_flag, %_sendto_fhs, $_cb, $_chunk_id, $_chunk_size, $_fd, $_file, $_flush_file, $_wa, @_is_c_ref, @_is_h_ref, @_is_q_ref, $_on_post_exit, $_on_post_run, $_has_user_tasks, $_sess_dir, $_task_id, $_user_error, $_user_output, $_input_size, $_offset_pos, $_single_dim, @_gather, $_cs_one_flag, $_exit_id, $_exit_pid, $_exit_status, $_exit_wid, $_len, $_sync_cnt, $_BSB_W_SOCK, $_BSE_W_SOCK, $_DAT_R_SOCK, $_DAU_R_SOCK, $_MCE_STDERR, $_I_FLG, $_O_FLG, $_I_SEP, $_O_SEP, $_RS, $_RS_FLG, $_MCE_STDOUT, $_win32_ipc ); ## ------------------------------------------------------------------------- ## Callback return. my $_cb_ret_a = sub { # CBK return array my $_buf = $self->{freeze}($_[0]); $_len = length $_buf; local $\ = undef if (defined $\); print {$_DAU_R_SOCK} $_len.$LF, $_buf; return; }; my $_cb_ret_r = sub { # CBK return reference my $_buf = $self->{freeze}($_[0]); $_len = length $_buf; local $\ = undef if (defined $\); print {$_DAU_R_SOCK} WANTS_REF.$LF . $_len.$LF, $_buf; return; }; my $_cb_ret_s = sub { # CBK return scalar $_len = (defined $_[0]) ? length $_[0] : -1; local $\ = undef if (defined $\); print {$_DAU_R_SOCK} WANTS_SCALAR.$LF . $_len.$LF, $_[0]; return; }; ## ------------------------------------------------------------------------- ## Create hash structure containing various output functions. my %_core_output_function = ( OUTPUT_W_ABT.$LF => sub { # Worker has aborted $_aborted = 1; return; }, OUTPUT_W_DNE.$LF => sub { # Worker has completed chomp($_task_id = <$_DAU_R_SOCK>); $self->{_total_running} -= 1; if ($_has_user_tasks && $_task_id >= 0) { $self->{_task}->[$_task_id]->{_total_running} -= 1; } my $_total_running = ($_has_user_tasks) ? $self->{_task}->[$_task_id]->{_total_running} : $self->{_total_running}; if ($_task_id == 0 && defined $_syn_flag && $_sync_cnt) { if ($_sync_cnt == $_total_running) { for (1 .. $_total_running) { syswrite $_BSB_W_SOCK, $LF } undef $_syn_flag; } } _task_end($self, $_task_id) unless ($_total_running); return; }, ## ---------------------------------------------------------------------- OUTPUT_W_EXT.$LF => sub { # Worker has exited chomp($_task_id = <$_DAU_R_SOCK>); $self->{_total_exited} += 1; $self->{_total_running} -= 1; $self->{_total_workers} -= 1; if ($_has_user_tasks && $_task_id >= 0) { $self->{_task}->[$_task_id]->{_total_running} -= 1; $self->{_task}->[$_task_id]->{_total_workers} -= 1; } my $_total_running = ($_has_user_tasks) ? $self->{_task}->[$_task_id]->{_total_running} : $self->{_total_running}; if ($_task_id == 0 && defined $_syn_flag && $_sync_cnt) { if ($_sync_cnt == $_total_running) { for (1 .. $_total_running) { syswrite $_BSB_W_SOCK, $LF } undef $_syn_flag; } } my ($_exit_msg, $_retry_buf) = ('', ''); chomp($_exit_wid = <$_DAU_R_SOCK>), chomp($_exit_pid = <$_DAU_R_SOCK>), chomp($_exit_status = <$_DAU_R_SOCK>), chomp($_exit_id = <$_DAU_R_SOCK>), chomp($_len = <$_DAU_R_SOCK>); read($_DAU_R_SOCK, $_exit_msg, $_len) if ($_len); chomp($_len = <$_DAU_R_SOCK>); read($_DAU_R_SOCK, $_retry_buf, $_len) if ($_len); if (abs($_exit_status) > abs($self->{_wrk_status})) { $self->{_wrk_status} = $_exit_status; } ## Reap child/thread. Note: Win32 uses negative PIDs. if ($_exit_pid =~ /^PID_(-?\d+)/) { my $_pid = $1; my $_list = $self->{_pids}; for my $i (0 .. @{ $_list }) { if ($_list->[$i] && $_list->[$i] == $_pid) { waitpid $_pid, 0; $self->{_pids}->[$i] = undef; last; } } } elsif ($_exit_pid =~ /^TID_(\d+)/) { my $_tid = $1; my $_list = $self->{_tids}; for my $i (0 .. @{ $_list }) { if ($_list->[$i] && $_list->[$i] == $_tid) { $self->{_thrs}->[$i]->join(); $self->{_thrs}->[$i] = undef; $self->{_tids}->[$i] = undef; last; } } } ## Call on_post_exit callback if defined. Otherwise, append status ## information if on_post_run is defined for later retrieval. if (defined $_on_post_exit) { $self->{_exited_wid} = $_exit_wid; if (length($_retry_buf)) { $self->{_retry} = $self->{thaw}($_retry_buf); my $_retry_cnt = $_max_retries - $self->{_retry}[2] - 1; $_on_post_exit->($self, { wid => $_exit_wid, pid => $_exit_pid, status => $_exit_status, msg => $_exit_msg, id => $_exit_id }, $_retry_cnt); delete $self->{_retry}; } else { $_on_post_exit->($self, { wid => $_exit_wid, pid => $_exit_pid, status => $_exit_status, msg => $_exit_msg, id => $_exit_id }, $_max_retries || 0 ); } delete $self->{_exited_wid}; } elsif (defined $_on_post_run) { push @{ $self->{_status} }, { wid => $_exit_wid, pid => $_exit_pid, status => $_exit_status, msg => $_exit_msg, id => $_exit_id }; } _task_end($self, $_task_id) unless ($_total_running); return; }, ## ---------------------------------------------------------------------- OUTPUT_A_ARY.$LF => sub { # Array << Array my $_buf; if ($_offset_pos >= $_input_size || $_aborted) { local $\ = undef if (defined $\); print {$_DAU_R_SOCK} '0'.$LF; return; } if ($_single_dim && $_cs_one_flag) { $_buf = $_input_data->[$_offset_pos]; } else { if ($_offset_pos + $_chunk_size - 1 < $_input_size) { $_buf = $self->{freeze}( [ @{ $_input_data }[ $_offset_pos .. $_offset_pos + $_chunk_size - 1 ] ] ); } else { $_buf = $self->{freeze}( [ @{ $_input_data }[ $_offset_pos .. $_input_size - 1 ] ] ); } } $_len = length $_buf; local $\ = undef if (defined $\); print {$_DAU_R_SOCK} $_len.$LF . (++$_chunk_id).$LF, $_buf; $_offset_pos += $_chunk_size; return; }, OUTPUT_S_GLB.$LF => sub { # Scalar << Glob FH my $_buf = ''; ## The logic below honors ('Ctrl/Z' in Windows, 'Ctrl/D' in Unix) ## when reading from standard input. No output will be lost as ## far as what was previously read into the buffer. if ($_eof_flag || $_aborted) { local $\ = undef if (defined $\); print {$_DAU_R_SOCK} '0'.$LF; return; } { local $/ = $_RS if ($_RS_FLG); if ($_chunk_size <= MAX_RECS_SIZE) { if ($_chunk_size == 1) { $_buf = <$_input_glob>; $_eof_flag = 1 unless (length $_buf); } else { my $_last_len = 0; for (1 .. $_chunk_size) { $_buf .= <$_input_glob>; $_len = length $_buf; if ($_len == $_last_len) { $_eof_flag = 1; last; } $_last_len = $_len; } } } else { if (read($_input_glob, $_buf, $_chunk_size) == $_chunk_size) { $_buf .= <$_input_glob>; $_eof_flag = 1 if (length $_buf == $_chunk_size); } else { $_eof_flag = 1; } } } $_len = length $_buf; local $\ = undef if (defined $\); if ($_len) { print {$_DAU_R_SOCK} $_len.$LF . (++$_chunk_id).$LF, $_buf; } else { print {$_DAU_R_SOCK} '0'.$LF; } return; }, OUTPUT_U_ITR.$LF => sub { # User << Iterator my $_buf; if ($_aborted) { local $\ = undef if (defined $\); print {$_DAU_R_SOCK} '-1'.$LF; return; } my @_ret_a = $_input_data->($_chunk_size); if (scalar @_ret_a > 1 || ref $_ret_a[0]) { $_buf = $self->{freeze}( [ @_ret_a ] ); $_len = length $_buf; local $\ = undef if (defined $\); print {$_DAU_R_SOCK} $_len.'1'.$LF . (++$_chunk_id).$LF, $_buf; return; } elsif (defined $_ret_a[0]) { $_len = length $_ret_a[0]; local $\ = undef if (defined $\); print {$_DAU_R_SOCK} $_len.'0'.$LF . (++$_chunk_id).$LF, $_ret_a[0]; return; } local $\ = undef if (defined $\); print {$_DAU_R_SOCK} '-1'.$LF; $_aborted = 1; return; }, ## ---------------------------------------------------------------------- OUTPUT_A_CBK.$LF => sub { # Callback w/ multiple args my ($_buf, $_data_ref); chomp($_wa = <$_DAU_R_SOCK>), chomp($_cb = <$_DAU_R_SOCK>), chomp($_len = <$_DAU_R_SOCK>); read $_DAU_R_SOCK, $_buf, $_len; $_data_ref = $self->{thaw}($_buf); undef $_buf; local $\ = $_O_SEP if ($_O_FLG); local $/ = $_I_SEP if ($_I_FLG); no strict 'refs'; if ($_wa == WANTS_UNDEF) { $_cb->(@{ $_data_ref }); } elsif ($_wa == WANTS_ARRAY) { my @_ret_a = $_cb->(@{ $_data_ref }); $_cb_ret_a->(\@_ret_a); } else { my $_ret_s = $_cb->(@{ $_data_ref }); ref $_ret_s ? $_cb_ret_r->($_ret_s) : $_cb_ret_s->($_ret_s); } return; }, OUTPUT_S_CBK.$LF => sub { # Callback w/ 1 scalar arg my $_buf; chomp($_wa = <$_DAU_R_SOCK>), chomp($_cb = <$_DAU_R_SOCK>), chomp($_len = <$_DAU_R_SOCK>); read $_DAU_R_SOCK, $_buf, $_len; local $\ = $_O_SEP if ($_O_FLG); local $/ = $_I_SEP if ($_I_FLG); no strict 'refs'; if ($_wa == WANTS_UNDEF) { $_cb->($_buf); } elsif ($_wa == WANTS_ARRAY) { my @_ret_a = $_cb->($_buf); $_cb_ret_a->(\@_ret_a); } else { my $_ret_s = $_cb->($_buf); ref $_ret_s ? $_cb_ret_r->($_ret_s) : $_cb_ret_s->($_ret_s); } return; }, OUTPUT_N_CBK.$LF => sub { # Callback w/ no args chomp($_wa = <$_DAU_R_SOCK>), chomp($_cb = <$_DAU_R_SOCK>); local $\ = $_O_SEP if ($_O_FLG); local $/ = $_I_SEP if ($_I_FLG); no strict 'refs'; if ($_wa == WANTS_UNDEF) { $_cb->(); } elsif ($_wa == WANTS_ARRAY) { my @_ret_a = $_cb->(); $_cb_ret_a->(\@_ret_a); } else { my $_ret_s = $_cb->(); ref $_ret_s ? $_cb_ret_r->($_ret_s) : $_cb_ret_s->($_ret_s); } return; }, ## ---------------------------------------------------------------------- OUTPUT_A_GTR.$LF => sub { # Gather array/ref my $_buf; chomp($_task_id = <$_DAU_R_SOCK>), chomp($_len = <$_DAU_R_SOCK>); read $_DAU_R_SOCK, $_buf, $_len; if ($_is_c_ref[$_task_id]) { local $_ = $self->{thaw}($_buf); $_gather[$_task_id]->(@{ $_ }); } elsif ($_is_h_ref[$_task_id]) { local $_ = $self->{thaw}($_buf); while (1) { my $_key = shift @{ $_ }; my $_val = shift @{ $_ }; $_gather[$_task_id]->{$_key} = $_val; last unless (@{ $_ }); } } elsif ($_is_q_ref[$_task_id]) { $_gather[$_task_id]->enqueue(@{ $self->{thaw}($_buf) }); } else { push @{ $_gather[$_task_id] }, @{ $self->{thaw}($_buf) }; } return; }, OUTPUT_S_GTR.$LF => sub { # Gather scalar local $_; chomp($_task_id = <$_DAU_R_SOCK>), chomp($_len = <$_DAU_R_SOCK>); read $_DAU_R_SOCK, $_, $_len if ($_len >= 0); if ($_is_c_ref[$_task_id]) { $_gather[$_task_id]->($_); } elsif ($_is_h_ref[$_task_id]) { $_gather[$_task_id]->{$_} = undef; } elsif ($_is_q_ref[$_task_id]) { $_gather[$_task_id]->enqueue($_); } else { push @{ $_gather[$_task_id] }, $_; } return; }, ## ---------------------------------------------------------------------- OUTPUT_O_SND.$LF => sub { # Send >> STDOUT my $_buf; chomp($_len = <$_DAU_R_SOCK>); read $_DAU_R_SOCK, $_buf, $_len; if (defined $_user_output) { $_user_output->($_buf); } else { print {$_MCE_STDOUT} $_buf; } return; }, OUTPUT_E_SND.$LF => sub { # Send >> STDERR my $_buf; chomp($_len = <$_DAU_R_SOCK>); read $_DAU_R_SOCK, $_buf, $_len; if (defined $_user_error) { $_user_error->($_buf); } else { print {$_MCE_STDERR} $_buf; } return; }, OUTPUT_F_SND.$LF => sub { # Send >> File my ($_buf, $_OUT_FILE); chomp($_file = <$_DAU_R_SOCK>), chomp($_len = <$_DAU_R_SOCK>); read $_DAU_R_SOCK, $_buf, $_len; unless (exists $_sendto_fhs{$_file}) { open $_sendto_fhs{$_file}, '>>', $_file or _croak "Cannot open file for writing ($_file): $!"; binmode $_sendto_fhs{$_file}; ## Select new FH, turn on autoflush, restore the old FH. if ($_flush_file) { local $|; select((select($_sendto_fhs{$_file}), $| = 1)[0]); } } $_OUT_FILE = $_sendto_fhs{$_file}; print {$_OUT_FILE} $_buf; return; }, OUTPUT_D_SND.$LF => sub { # Send >> File descriptor my ($_buf, $_OUT_FILE); chomp($_fd = <$_DAU_R_SOCK>), chomp($_len = <$_DAU_R_SOCK>); read $_DAU_R_SOCK, $_buf, $_len; unless (exists $_sendto_fhs{$_fd}) { require IO::Handle unless (defined $IO::Handle::VERSION); $_sendto_fhs{$_fd} = IO::Handle->new(); $_sendto_fhs{$_fd}->fdopen($_fd, 'w') or _croak "Cannot open file descriptor ($_fd): $!"; binmode $_sendto_fhs{$_fd}; ## Select new FH, turn on autoflush, restore the old FH. if ($_flush_file) { local $|; select((select($_sendto_fhs{$_fd}), $| = 1)[0]); } } $_OUT_FILE = $_sendto_fhs{$_fd}; print {$_OUT_FILE} $_buf; return; }, ## ---------------------------------------------------------------------- OUTPUT_B_SYN.$LF => sub { # Barrier sync - begin if (!defined $_sync_cnt || $_sync_cnt == 0) { $_syn_flag = 1, $_sync_cnt = 0; } my $_total_running = ($_has_user_tasks) ? $self->{_task}->[0]->{_total_running} : $self->{_total_running}; if (++$_sync_cnt == $_total_running) { for (1 .. $_total_running) { syswrite $_BSB_W_SOCK, $LF } undef $_syn_flag; } return; }, OUTPUT_E_SYN.$LF => sub { # Barrier sync - end if (--$_sync_cnt == 0) { my $_total_running = ($_has_user_tasks) ? $self->{_task}->[0]->{_total_running} : $self->{_total_running}; for (1 .. $_total_running) { syswrite $_BSE_W_SOCK, $LF } } return; }, OUTPUT_S_IPC.$LF => sub { # Change to win32 IPC syswrite $_DAT_R_SOCK, $LF; $_win32_ipc = 1, goto _LOOP unless $_win32_ipc; return; }, ); ## ------------------------------------------------------------------------- local ($!, $?, $_); $_has_user_tasks = (defined $self->{user_tasks}) ? 1 : 0; $_cs_one_flag = ($self->{chunk_size} == 1) ? 1 : 0; $_aborted = $_chunk_id = $_eof_flag = 0; $_max_retries = $self->{max_retries}; $_on_post_exit = $self->{on_post_exit}; $_on_post_run = $self->{on_post_run}; $_chunk_size = $self->{chunk_size}; $_flush_file = $self->{flush_file}; $_user_output = $self->{user_output}; $_user_error = $self->{user_error}; $_single_dim = $self->{_single_dim}; $_sess_dir = $self->{_sess_dir}; if ($_max_retries && !$_on_post_exit) { $_on_post_exit = sub { my ($self, $_e, $_retry_cnt) = @_; my ($_cnt, $_msg) = ($_retry_cnt + 1, "Error: Chunk $_e->{id} failed"); ($_retry_cnt < $_max_retries) ? print {*STDERR} "$_msg, retrying chunk attempt #${_cnt}\n" : print {*STDERR} "$_msg\n"; $self->restart_worker; }; } if ($_has_user_tasks && $self->{user_tasks}->[0]->{chunk_size}) { $_chunk_size = $self->{user_tasks}->[0]->{chunk_size}; } if ($_has_user_tasks) { for my $_i (0 .. @{ $self->{user_tasks} } - 1) { $_gather[$_i] = (defined $self->{user_tasks}->[$_i]->{gather}) ? $self->{user_tasks}->[$_i]->{gather} : $self->{gather}; $_is_c_ref[$_i] = ( ref $_gather[$_i] eq 'CODE' ) ? 1 : 0; $_is_h_ref[$_i] = ( ref $_gather[$_i] eq 'HASH' ) ? 1 : 0; $_is_q_ref[$_i] = ( ref $_gather[$_i] eq 'MCE::Queue' || ref $_gather[$_i] eq 'Thread::Queue' ) ? 1 : 0; } } if (defined $self->{gather}) { $_gather[0] = $self->{gather}; $_is_c_ref[0] = ( ref $_gather[0] eq 'CODE' ) ? 1 : 0; $_is_h_ref[0] = ( ref $_gather[0] eq 'HASH' ) ? 1 : 0; $_is_q_ref[0] = ( ref $_gather[0] eq 'MCE::Queue' || ref $_gather[0] eq 'Thread::Queue' ) ? 1 : 0; } if (defined $_input_data && ref $_input_data eq 'ARRAY') { $_input_size = @{ $_input_data }; $_offset_pos = 0; } else { $_input_size = $_offset_pos = 0; } ## Set STDOUT/STDERR to user parameters. if (defined $self->{stdout_file}) { open $_MCE_STDOUT, '>>', $self->{stdout_file} or die $self->{stdout_file} . ": $!\n"; binmode $_MCE_STDOUT; } else { $_MCE_STDOUT = \*STDOUT; binmode $_MCE_STDOUT; } if (defined $self->{stderr_file}) { open $_MCE_STDERR, '>>', $self->{stderr_file} or die $self->{stderr_file} . ": $!\n"; binmode $_MCE_STDERR; } else { $_MCE_STDERR = \*STDERR; binmode $_MCE_STDERR; } ## Make MCE_STDOUT the default handle. ## Flush STDERR/STDOUT handles if requested. my $_old_hndl = select $_MCE_STDOUT; if ($self->{flush_stdout}) { local $|; select((select($_MCE_STDOUT), $| = 1)[0]); } if ($self->{flush_stderr}) { local $|; select((select($_MCE_STDERR), $| = 1)[0]); } ## ------------------------------------------------------------------------- ## Output event loop. my $_func; my $_channels = $self->{_dat_r_sock}; $_win32_ipc = ( $ENV{'PERL_MCE_IPC'} eq 'win32' || $INC{'MCE/Hobo.pm'} ); $_BSB_W_SOCK = $self->{_bsb_w_sock}; $_BSE_W_SOCK = $self->{_bse_w_sock}; $_DAT_R_SOCK = $self->{_dat_r_sock}->[0]; $_RS = $self->{RS} || $/; $_O_SEP = $\; local $\ = undef; $_I_SEP = $/; local $/ = $LF; $_RS_FLG = (!$_RS || $_RS ne $LF) ? 1 : 0; $_O_FLG = (defined $_O_SEP) ? 1 : 0; $_I_FLG = (!$_I_SEP || $_I_SEP ne $LF) ? 1 : 0; ## Call module's loop_begin routine for modules plugged into MCE. for my $_p (@{ $_plugin_loop_begin }) { $_p->($self, \$_DAU_R_SOCK); } ## Wait on requests *with* timeout capability. Exit loop when all workers ## have completed processing or exited prematurely. _LOOP: if ($self->{loop_timeout} && @{ $self->{_tids} } == 0 && $^O ne 'MSWin32') { my ($_list, $_timeout) = ($self->{_pids}, $self->{loop_timeout}); my ($_DAT_W_SOCK, $_pid) = ($self->{_dat_w_sock}->[0]); $_timeout = 5 if $_timeout < 5; local $SIG{ALRM} = sub { alarm 0; for my $i (0 .. @{ $_list }) { if ($_pid = $_list->[$i]) { if (waitpid($_pid, _WNOHANG)) { $self->{_total_exited} += 1; $self->{_total_running} -= 1; $self->{_total_workers} -= 1; $_list->[$i] = undef; } } } print {$_DAT_W_SOCK} 'NOOP'.$LF . '0'.$LF; }; while ( $self->{_total_running} ) { alarm $_timeout; $_func = <$_DAT_R_SOCK>; $_DAU_R_SOCK = $_channels->[ <$_DAT_R_SOCK> ]; alarm 0; if (exists $_core_output_function{$_func}) { $_core_output_function{$_func}(); } elsif (exists $_plugin_function->{$_func}) { $_plugin_function->{$_func}(); } } } ## Wait on requests *without* timeout capability. elsif ($^O eq 'MSWin32' && $_win32_ipc) { # The normal loop hangs on Windows when processes/threads start/exit. # Using ioctl() properly, http://www.perlmonks.org/?node_id=780083 my $_val_bytes = "\x00\x00\x00\x00"; my $_ptr_bytes = unpack( 'I', pack('P', $_val_bytes) ); my ($_count, $_done, $_nbytes, $_start) = (1, 0); while (!$_done) { $_start = time; # MSWin32 FIONREAD IOCTL: ioctl($_DAT_R_SOCK, 0x4004667f, $_ptr_bytes); unless ($_nbytes = unpack('I', $_val_bytes)) { if ($_count) { # delay after a while to not consume a CPU core $_count = 0 if ++$_count % 50 == 0 && time - $_start > 0.030; } else { sleep 0.030; } goto IOCTL; } $_count = 1; do { sysread($_DAT_R_SOCK, $_func, 8); $_done = 1, last() unless length($_func) == 8; $_DAU_R_SOCK = $_channels->[ substr($_func, -2, 2, '') ]; if (exists $_core_output_function{$_func}) { $_core_output_function{$_func}(); } elsif (exists $_plugin_function->{$_func}) { $_plugin_function->{$_func}(); } } while (($_nbytes -= 8) >= 8); last unless $self->{_total_running}; } } elsif ($^O eq 'MSWin32') { while ($self->{_total_running}) { sysread($_DAT_R_SOCK, $_func, 8); last() unless length($_func) == 8; $_DAU_R_SOCK = $_channels->[ substr($_func, -2, 2, '') ]; if (exists $_core_output_function{$_func}) { $_core_output_function{$_func}(); } elsif (exists $_plugin_function->{$_func}) { $_plugin_function->{$_func}(); } } } else { while ($self->{_total_running}) { $_func = <$_DAT_R_SOCK>; last() unless length($_func) == 6; $_DAU_R_SOCK = $_channels->[ <$_DAT_R_SOCK> ]; if (exists $_core_output_function{$_func}) { $_core_output_function{$_func}(); } elsif (exists $_plugin_function->{$_func}) { $_plugin_function->{$_func}(); } } } ## Call module's loop_end routine for modules plugged into MCE. for my $_p (@{ $_plugin_loop_end }) { $_p->($self); } ## Call on_post_run callback. $_on_post_run->($self, $self->{_status}) if (defined $_on_post_run); ## Close opened sendto file handles. for my $_p (keys %_sendto_fhs) { close $_sendto_fhs{$_p}; undef $_sendto_fhs{$_p}; delete $_sendto_fhs{$_p}; } ## Restore the default handle. Close MCE STDOUT/STDERR handles. select $_old_hndl; eval q{ close $_MCE_STDOUT if (fileno $_MCE_STDOUT > 2); close $_MCE_STDERR if (fileno $_MCE_STDERR > 2); }; return; } 1; MCE-1.810/lib/MCE/Grep.pm0000644000175000017500000005241113022712400013526 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## Parallel grep model similar to the native grep function. ## ############################################################################### package MCE::Grep; use strict; use warnings; no warnings qw( threads recursion uninitialized ); our $VERSION = '1.810'; ## no critic (BuiltinFunctions::ProhibitStringyEval) ## no critic (Subroutines::ProhibitSubroutinePrototypes) ## no critic (TestingAndDebugging::ProhibitNoStrict) use Scalar::Util qw( looks_like_number weaken ); use MCE; our @CARP_NOT = qw( MCE ); my $_has_threads = $INC{'threads.pm'} ? 1 : 0; my $_tid = $_has_threads ? threads->tid() : 0; sub CLONE { $_tid = threads->tid() if $_has_threads; } ############################################################################### ## ---------------------------------------------------------------------------- ## Import routine. ## ############################################################################### my ($_MCE, $_def, $_params, $_prev_c, $_tag) = ({}, {}, {}, {}, 'MCE::Grep'); sub import { my ($_class, $_pkg) = (shift, caller); my $_p = $_def->{$_pkg} = { MAX_WORKERS => 'auto', CHUNK_SIZE => 'auto', }; ## Import functions. no strict 'refs'; no warnings 'redefine'; *{ $_pkg.'::mce_grep_f' } = \&run_file; *{ $_pkg.'::mce_grep_s' } = \&run_seq; *{ $_pkg.'::mce_grep' } = \&run; ## Process module arguments. while ( my $_argument = shift ) { my $_arg = lc $_argument; $_p->{MAX_WORKERS} = shift, next if ( $_arg eq 'max_workers' ); $_p->{CHUNK_SIZE} = shift, next if ( $_arg eq 'chunk_size' ); $_p->{TMP_DIR} = shift, next if ( $_arg eq 'tmp_dir' ); $_p->{FREEZE} = shift, next if ( $_arg eq 'freeze' ); $_p->{THAW} = shift, next if ( $_arg eq 'thaw' ); ## Sereal 3.008+, if available, is used automatically by MCE 1.800. if ( $_arg eq 'sereal' ) { if ( shift eq '0' ) { require Storable; $_p->{FREEZE} = \&Storable::freeze; $_p->{THAW} = \&Storable::thaw; } next; } _croak("Error: ($_argument) invalid module option"); } $_p->{MAX_WORKERS} = MCE::Util::_parse_max_workers($_p->{MAX_WORKERS}); _validate_number($_p->{MAX_WORKERS}, 'MAX_WORKERS'); _validate_number($_p->{CHUNK_SIZE}, 'CHUNK_SIZE') unless ($_p->{CHUNK_SIZE} eq 'auto'); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Gather callback for storing by chunk_id => chunk_ref into a hash. ## ############################################################################### my ($_total_chunks, %_tmp); sub _gather { my ($_chunk_id, $_data_ref) = @_; $_tmp{$_chunk_id} = $_data_ref; $_total_chunks++; return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Init and finish routines. ## ############################################################################### sub init (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Grep'); my $_pkg = "$$.$_tid.".caller(); $_params->{$_pkg} = (ref $_[0] eq 'HASH') ? shift : { @_ }; @_ = (); return; } sub finish (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Grep'); my $_pkg = (defined $_[0]) ? shift : "$$.$_tid.".caller(); if ( $_pkg eq 'MCE' ) { for my $_k ( keys %{ $_MCE } ) { MCE::Grep->finish($_k, 1); } } elsif ( $_MCE->{$_pkg} && $_MCE->{$_pkg}{_init_pid} eq "$$.$_tid" ) { $_MCE->{$_pkg}->shutdown(@_) if $_MCE->{$_pkg}{_spawned}; $_total_chunks = undef, undef %_tmp; delete $_prev_c->{$_pkg}; delete $_MCE->{$_pkg}; } @_ = (); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Parallel grep with MCE -- file. ## ############################################################################### sub run_file (&@) { shift if (defined $_[0] && $_[0] eq 'MCE::Grep'); my $_code = shift; my $_file = shift; my $_pid = "$$.$_tid.".caller(); if (defined (my $_p = $_params->{$_pid})) { delete $_p->{input_data} if (exists $_p->{input_data}); delete $_p->{sequence} if (exists $_p->{sequence}); } else { $_params->{$_pid} = {}; } if (defined $_file && ref $_file eq '' && $_file ne '') { _croak("$_tag: ($_file) does not exist") unless (-e $_file); _croak("$_tag: ($_file) is not readable") unless (-r $_file); _croak("$_tag: ($_file) is not a plain file") unless (-f $_file); $_params->{$_pid}{_file} = $_file; } elsif (ref $_file eq 'SCALAR' || ref($_file) =~ /^(?:GLOB|FileHandle|IO::)/) { $_params->{$_pid}{_file} = $_file; } else { _croak("$_tag: (file) is not specified or valid"); } @_ = (); return run($_code); } ############################################################################### ## ---------------------------------------------------------------------------- ## Parallel grep with MCE -- sequence. ## ############################################################################### sub run_seq (&@) { shift if (defined $_[0] && $_[0] eq 'MCE::Grep'); my $_code = shift; my $_pid = "$$.$_tid.".caller(); if (defined (my $_p = $_params->{$_pid})) { delete $_p->{input_data} if (exists $_p->{input_data}); delete $_p->{_file} if (exists $_p->{_file}); } else { $_params->{$_pid} = {}; } my ($_begin, $_end); if (ref $_[0] eq 'HASH') { $_begin = $_[0]->{begin}; $_end = $_[0]->{end}; $_params->{$_pid}{sequence} = $_[0]; } elsif (ref $_[0] eq 'ARRAY') { $_begin = $_[0]->[0]; $_end = $_[0]->[1]; $_params->{$_pid}{sequence} = $_[0]; } elsif (ref $_[0] eq '') { $_begin = $_[0]; $_end = $_[1]; $_params->{$_pid}{sequence} = [ @_ ]; } else { _croak("$_tag: (sequence) is not specified or valid"); } _croak("$_tag: (begin) is not specified for sequence") unless (defined $_begin); _croak("$_tag: (end) is not specified for sequence") unless (defined $_end); $_params->{$_pid}{sequence_run} = 1; @_ = (); return run($_code); } ############################################################################### ## ---------------------------------------------------------------------------- ## Parallel grep with MCE. ## ############################################################################### sub run (&@) { shift if (defined $_[0] && $_[0] eq 'MCE::Grep'); my $_code = shift; $_total_chunks = 0; undef %_tmp; my $_pkg = caller() eq 'MCE::Grep' ? caller(1) : caller(); my $_pid = "$$.$_tid.$_pkg"; my $_input_data; my $_max_workers = $_def->{$_pkg}{MAX_WORKERS}; my $_r = ref $_[0]; if ($_r eq 'ARRAY' || $_r eq 'CODE' || $_r eq 'SCALAR' || $_r =~ /^(?:GLOB|FileHandle|IO::)/) { $_input_data = shift if (@_ == 1); } if (defined (my $_p = $_params->{$_pid})) { $_max_workers = MCE::Util::_parse_max_workers($_p->{max_workers}) if (exists $_p->{max_workers}); delete $_p->{sequence} if (defined $_input_data || scalar @_); delete $_p->{user_func} if (exists $_p->{user_func}); delete $_p->{user_tasks} if (exists $_p->{user_tasks}); delete $_p->{use_slurpio} if (exists $_p->{use_slurpio}); delete $_p->{bounds_only} if (exists $_p->{bounds_only}); delete $_p->{gather} if (exists $_p->{gather}); } my $_chunk_size = MCE::Util::_parse_chunk_size( $_def->{$_pkg}{CHUNK_SIZE}, $_max_workers, $_params->{$_pid}, $_input_data, scalar @_ ); if (defined (my $_p = $_params->{$_pid})) { if (exists $_p->{_file}) { $_input_data = delete $_p->{_file}; } else { $_input_data = $_p->{input_data} if exists $_p->{input_data}; } } ## ------------------------------------------------------------------------- MCE::_save_state(); if (!defined $_prev_c->{$_pid} || $_prev_c->{$_pid} != $_code) { $_MCE->{$_pid}->shutdown() if (defined $_MCE->{$_pid}); $_prev_c->{$_pid} = $_code; my %_opts = ( max_workers => $_max_workers, task_name => $_tag, user_func => sub { my ($_mce, $_chunk_ref, $_chunk_id) = @_; my $_wantarray = $_mce->{user_args}[0]; if ($_wantarray) { my @_a; if (ref $_chunk_ref eq 'SCALAR') { local $/ = $_mce->{RS} if defined $_mce->{RS}; open my $_MEM_FH, '<', $_chunk_ref; binmode $_MEM_FH, ':raw'; while (<$_MEM_FH>) { push (@_a, $_) if &{ $_code }; } close $_MEM_FH; weaken $_MEM_FH; } else { if (ref $_chunk_ref) { push @_a, grep { &{ $_code } } @{ $_chunk_ref }; } else { push @_a, grep { &{ $_code } } $_chunk_ref; } } MCE->gather($_chunk_id, \@_a); } else { my $_cnt = 0; if (ref $_chunk_ref eq 'SCALAR') { local $/ = $_mce->{RS} if defined $_mce->{RS}; open my $_MEM_FH, '<', $_chunk_ref; binmode $_MEM_FH, ':raw'; while (<$_MEM_FH>) { $_cnt++ if &{ $_code }; } close $_MEM_FH; weaken $_MEM_FH; } else { if (ref $_chunk_ref) { $_cnt += grep { &{ $_code } } @{ $_chunk_ref }; } else { $_cnt += grep { &{ $_code } } $_chunk_ref; } } MCE->gather($_cnt) if defined $_wantarray; } }, ); if (defined (my $_p = $_params->{$_pid})) { for my $_k (keys %{ $_p }) { next if ($_k eq 'sequence_run'); next if ($_k eq 'input_data'); next if ($_k eq 'chunk_size'); _croak("MCE::Grep: ($_k) is not a valid constructor argument") unless (exists $MCE::_valid_fields_new{$_k}); $_opts{$_k} = $_p->{$_k}; } } for my $_k (qw/ tmp_dir freeze thaw /) { $_opts{$_k} = $_def->{$_pkg}{uc($_k)} if (exists $_def->{$_pkg}{uc($_k)} && !exists $_opts{$_k}); } $_MCE->{$_pid} = MCE->new(pkg => $_pkg, %_opts); } ## ------------------------------------------------------------------------- my $_cnt = 0; my $_wantarray = wantarray; $_MCE->{$_pid}{use_slurpio} = ($_chunk_size > &MCE::MAX_RECS_SIZE) ? 1 : 0; $_MCE->{$_pid}{user_args} = [ $_wantarray ]; $_MCE->{$_pid}{gather} = $_wantarray ? \&_gather : sub { $_cnt += $_[0]; return; }; if (defined $_input_data) { @_ = (); $_MCE->{$_pid}->process({ chunk_size => $_chunk_size }, $_input_data); delete $_MCE->{$_pid}{input_data}; } elsif (scalar @_) { $_MCE->{$_pid}->process({ chunk_size => $_chunk_size }, \@_); delete $_MCE->{$_pid}{input_data}; } else { if (defined $_params->{$_pid} && exists $_params->{$_pid}{sequence}) { $_MCE->{$_pid}->run({ chunk_size => $_chunk_size, sequence => $_params->{$_pid}{sequence} }, 0); if (exists $_params->{$_pid}{sequence_run}) { delete $_params->{$_pid}{sequence_run}; delete $_params->{$_pid}{sequence}; } delete $_MCE->{$_pid}{sequence}; } } MCE::_restore_state(); if ($_wantarray) { return map { @{ $_ } } delete @_tmp{ 1 .. $_total_chunks }; } elsif (defined $_wantarray) { return $_cnt; } return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Private methods. ## ############################################################################### sub _croak { goto &MCE::_croak; } sub _validate_number { my ($_n, $_key) = @_; _croak("$_tag: ($_key) is not valid") if (!defined $_n); $_n =~ s/K\z//i; $_n =~ s/M\z//i; if (!looks_like_number($_n) || int($_n) != $_n || $_n < 1) { _croak("$_tag: ($_key) is not valid"); } return; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Grep - Parallel grep model similar to the native grep function =head1 VERSION This document describes MCE::Grep version 1.810 =head1 SYNOPSIS ## Exports mce_grep, mce_grep_f, and mce_grep_s use MCE::Grep; ## Array or array_ref my @a = mce_grep { $_ % 5 == 0 } 1..10000; my @b = mce_grep { $_ % 5 == 0 } [ 1..10000 ]; ## File_path, glob_ref, or scalar_ref my @c = mce_grep_f { /pattern/ } "/path/to/file"; my @d = mce_grep_f { /pattern/ } $file_handle; my @e = mce_grep_f { /pattern/ } \$scalar; ## Sequence of numbers (begin, end [, step, format]) my @f = mce_grep_s { %_ * 3 == 0 } 1, 10000, 5; my @g = mce_grep_s { %_ * 3 == 0 } [ 1, 10000, 5 ]; my @h = mce_grep_s { %_ * 3 == 0 } { begin => 1, end => 10000, step => 5, format => undef }; =head1 DESCRIPTION This module provides a parallel grep implementation via Many-Core Engine. MCE incurs a small overhead due to passing of data. A fast code block will run faster natively. However, the overhead will likely diminish as the complexity increases for the code. my @m1 = grep { $_ % 5 == 0 } 1..1000000; ## 0.065 secs my @m2 = mce_grep { $_ % 5 == 0 } 1..1000000; ## 0.194 secs Chunking, enabled by default, greatly reduces the overhead behind the scene. The time for mce_grep below also includes the time for data exchanges between the manager and worker processes. More parallelization will be seen when the code incurs additional CPU time. my @m1 = grep { /[2357][1468][9]/ } 1..1000000; ## 0.353 secs my @m2 = mce_grep { /[2357][1468][9]/ } 1..1000000; ## 0.218 secs Even faster is mce_grep_s; useful when input data is a range of numbers. Workers generate sequences mathematically among themselves without any interaction from the manager process. Two arguments are required for mce_grep_s (begin, end). Step defaults to 1 if begin is smaller than end, otherwise -1. my @m3 = mce_grep_s { /[2357][1468][9]/ } 1, 1000000; ## 0.165 secs Although this document is about MCE::Grep, the L module can write results immediately without waiting for all chunks to complete. This is made possible by passing the reference to an array (in this case @m4 and @m5). use MCE::Stream default_mode => 'grep'; my @m4; mce_stream \@m4, sub { /[2357][1468][9]/ }, 1..1000000; ## Completed in 0.203 secs. This is amazing considering the ## overhead for passing data between the manager and workers. my @m5; mce_stream_s \@m5, sub { /[2357][1468][9]/ }, 1, 1000000; ## Completed in 0.120 secs. Like with mce_grep_s, specifying a ## sequence specification turns out to be faster due to lesser ## overhead for the manager process. A common scenario is grepping for pattern(s) inside a massive log file. Notice how parallelism increases as complexity increases for the pattern. Testing was done against a 300 MB file containing 250k lines. use MCE::Grep; my @m; open my $LOG, "<", "/path/to/log/file" or die "$!\n"; @m = grep { /pattern/ } <$LOG>; ## 0.756 secs @m = grep { /foobar|[2357][1468][9]/ } <$LOG>; ## 24.681 secs ## Parallelism with mce_grep. This involves the manager process ## due to processing a file handle. @m = mce_grep { /pattern/ } <$LOG>; ## 0.997 secs @m = mce_grep { /foobar|[2357][1468][9]/ } <$LOG>; ## 7.439 secs ## Even faster with mce_grep_f. Workers access the file directly ## with zero interaction from the manager process. my $LOG = "/path/to/file"; @m = mce_grep_f { /pattern/ } $LOG; ## 0.112 secs @m = mce_grep_f { /foobar|[2357][1468][9]/ } $LOG; ## 6.840 secs =head1 PARSING HUGE FILES The MCE::Grep module lacks an optimization for quickly determining if a match is found from not knowing the pattern inside the code block. Use the following snippet as a template to achieve better performance. Also, take a look at examples/egrep.pl, included with the distribution. use MCE::Loop; MCE::Loop::init { max_workers => 8, use_slurpio => 1 }; my $pattern = 'karl'; my $hugefile = 'very_huge.file'; my @result = mce_loop_f { my ($mce, $slurp_ref, $chunk_id) = @_; ## Quickly determine if a match is found. ## Process slurped chunk only if true. if ($$slurp_ref =~ /$pattern/m) { my @matches; ## The following is fast on Unix. Performance degrades ## drastically on Windows beyond 4 workers. open my $MEM_FH, '<', $slurp_ref; binmode $MEM_FH, ':raw'; while (<$MEM_FH>) { push @matches, $_ if (/$pattern/); } close $MEM_FH; ## Therefore, use the following construct on Windows. while ( $$slurp_ref =~ /([^\n]+\n)/mg ) { my $line = $1; # save $1 to not lose the value push @matches, $line if ($line =~ /$pattern/); } ## Gather matched lines. MCE->gather(@matches); } } $hugefile; print join('', @result); =head1 OVERRIDING DEFAULTS The following list options which may be overridden when loading the module. use Sereal qw( encode_sereal decode_sereal ); use CBOR::XS qw( encode_cbor decode_cbor ); use JSON::XS qw( encode_json decode_json ); use MCE::Grep max_workers => 4, # Default 'auto' chunk_size => 100, # Default 'auto' tmp_dir => "/path/to/app/tmp", # $MCE::Signal::tmp_dir freeze => \&encode_sereal, # \&Storable::freeze thaw => \&decode_sereal # \&Storable::thaw ; From MCE 1.8 onwards, Sereal 3.008+ is loaded automatically if available. Specify C 0> to use Storable instead. use MCE::Grep Sereal => 0; =head1 CUSTOMIZING MCE =over 3 =item MCE::Grep->init ( options ) =item MCE::Grep::init { options } The init function accepts a hash of MCE options. The gather option, if specified, is ignored due to being used internally by the module. use MCE::Grep; MCE::Grep::init { chunk_size => 1, max_workers => 4, user_begin => sub { print "## ", MCE->wid, " started\n"; }, user_end => sub { print "## ", MCE->wid, " completed\n"; } }; my @a = mce_grep { $_ % 5 == 0 } 1..100; print "\n", "@a", "\n"; -- Output ## 2 started ## 3 started ## 1 started ## 4 started ## 3 completed ## 4 completed ## 1 completed ## 2 completed 5 10 15 20 25 30 35 40 45 50 55 60 65 70 75 80 85 90 95 100 =back =head1 API DOCUMENTATION =over 3 =item MCE::Grep->run ( sub { code }, iterator ) =item mce_grep { code } iterator An iterator reference can by specified for input_data. Iterators are described under "SYNTAX for INPUT_DATA" at L. my @a = mce_grep { $_ % 3 == 0 } make_iterator(10, 30, 2); =item MCE::Grep->run ( sub { code }, list ) =item mce_grep { code } list Input data can be defined using a list. my @a = mce_grep { /[2357]/ } 1..1000; my @b = mce_grep { /[2357]/ } [ 1..1000 ]; =item MCE::Grep->run_file ( sub { code }, file ) =item mce_grep_f { code } file The fastest of these is the /path/to/file. Workers communicate the next offset position among themselves without any interaction from the manager process. my @c = mce_grep_f { /pattern/ } "/path/to/file"; my @d = mce_grep_f { /pattern/ } $file_handle; my @e = mce_grep_f { /pattern/ } \$scalar; =item MCE::Grep->run_seq ( sub { code }, $beg, $end [, $step, $fmt ] ) =item mce_grep_s { code } $beg, $end [, $step, $fmt ] Sequence can be defined as a list, an array reference, or a hash reference. The functions require both begin and end values to run. Step and format are optional. The format is passed to sprintf (% may be omitted below). my ($beg, $end, $step, $fmt) = (10, 20, 0.1, "%4.1f"); my @f = mce_grep_s { /[1234]\.[5678]/ } $beg, $end, $step, $fmt; my @g = mce_grep_s { /[1234]\.[5678]/ } [ $beg, $end, $step, $fmt ]; my @h = mce_grep_s { /[1234]\.[5678]/ } { begin => $beg, end => $end, step => $step, format => $fmt }; =back =head1 MANUAL SHUTDOWN =over 3 =item MCE::Grep->finish =item MCE::Grep::finish Workers remain persistent as much as possible after running. Shutdown occurs automatically when the script terminates. Call finish when workers are no longer needed. use MCE::Grep; MCE::Grep::init { chunk_size => 20, max_workers => 'auto' }; my @a = mce_grep { ... } 1..100; MCE::Grep::finish; =back =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.810/lib/MCE/Stream.pm0000644000175000017500000007352513022712423014102 0ustar mariomario############################################################################### ## ---------------------------------------------------------------------------- ## Parallel stream model for chaining multiple maps and greps. ## ############################################################################### package MCE::Stream; use strict; use warnings; no warnings qw( threads recursion uninitialized ); our $VERSION = '1.810'; ## no critic (BuiltinFunctions::ProhibitStringyEval) ## no critic (Subroutines::ProhibitSubroutinePrototypes) ## no critic (TestingAndDebugging::ProhibitNoStrict) use Scalar::Util qw( looks_like_number ); use MCE; use MCE::Queue; our @CARP_NOT = qw( MCE ); my $_has_threads = $INC{'threads.pm'} ? 1 : 0; my $_tid = $_has_threads ? threads->tid() : 0; sub CLONE { $_tid = threads->tid() if $_has_threads; } ############################################################################### ## ---------------------------------------------------------------------------- ## Import routine. ## ############################################################################### my ($_MCE, $_def, $_params, $_tag) = ({}, {}, {}, 'MCE::Stream'); my ($_prev_c, $_prev_m, $_prev_n, $_prev_w) = ({}, {}, {}, {}); my ($_user_tasks, $_queue) = ({}, {}); sub import { my ($_class, $_pkg) = (shift, caller); my $_p = $_def->{$_pkg} = { MAX_WORKERS => 'auto', CHUNK_SIZE => 'auto', DEFAULT_MODE => 'map', FAST => 0, }; ## Import functions. no strict 'refs'; no warnings 'redefine'; *{ $_pkg.'::mce_stream_f' } = \&run_file; *{ $_pkg.'::mce_stream_s' } = \&run_seq; *{ $_pkg.'::mce_stream' } = \&run; ## Process module arguments. while ( my $_argument = shift ) { my $_arg = lc $_argument; $_p->{MAX_WORKERS} = shift, next if ( $_arg eq 'max_workers' ); $_p->{CHUNK_SIZE} = shift, next if ( $_arg eq 'chunk_size' ); $_p->{TMP_DIR} = shift, next if ( $_arg eq 'tmp_dir' ); $_p->{FREEZE} = shift, next if ( $_arg eq 'freeze' ); $_p->{THAW} = shift, next if ( $_arg eq 'thaw' ); $_p->{DEFAULT_MODE} = shift, next if ( $_arg eq 'default_mode' ); $_p->{FAST} = shift, next if ( $_arg eq 'fast' ); ## Sereal 3.008+, if available, is used automatically by MCE 1.800. if ( $_arg eq 'sereal' ) { if ( shift eq '0' ) { require Storable; $_p->{FREEZE} = \&Storable::freeze; $_p->{THAW} = \&Storable::thaw; } next; } _croak("Error: ($_argument) invalid module option"); } _croak("Error: (DEFAULT_MODE) is not valid") if ($_p->{DEFAULT_MODE} ne 'grep' && $_p->{DEFAULT_MODE} ne 'map'); $_p->{MAX_WORKERS} = MCE::Util::_parse_max_workers($_p->{MAX_WORKERS}); _validate_number($_p->{MAX_WORKERS}, 'MAX_WORKERS'); _validate_number($_p->{CHUNK_SIZE}, 'CHUNK_SIZE') unless ($_p->{CHUNK_SIZE} eq 'auto'); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Gather callback to ensure chunk order is preserved during gathering. ## Also, the task end callback for when a task completes. ## ############################################################################### my ($_gather_ref, $_order_id, %_tmp); sub _preserve_order { $_tmp{$_[1]} = $_[0]; if (defined $_gather_ref) { while (1) { last unless exists $_tmp{$_order_id}; push @{ $_gather_ref }, @{ delete $_tmp{$_order_id++} }; } } else { $_order_id++; } return; } sub _task_end { my ($_mce, $_task_id, $_task_name) = @_; my $_pid = $_mce->{_init_pid}.'.'.$_mce->{_caller}; if (defined $_mce->{user_tasks}->[$_task_id + 1]) { my $n_workers = $_mce->{user_tasks}->[$_task_id + 1]->{max_workers}; my $_id = @{ $_queue->{$_pid} } - $_task_id - 1; $_queue->{$_pid}[$_id]->enqueue((undef) x $n_workers); } $_params->{task_end}->($_mce, $_task_id, $_task_name) if (exists $_params->{task_end} && ref $_params->{task_end} eq 'CODE'); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Init and finish routines. ## ############################################################################### sub init (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Stream'); my $_pkg = "$$.$_tid.".caller(); $_params->{$_pkg} = (ref $_[0] eq 'HASH') ? shift : { @_ }; @_ = (); return; } sub finish (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Stream'); my $_pkg = (defined $_[0]) ? shift : "$$.$_tid.".caller(); if ( $_pkg eq 'MCE' ) { for my $_k ( keys %{ $_MCE } ) { MCE::Stream->finish($_k, 1); } } elsif ( $_MCE->{$_pkg} && $_MCE->{$_pkg}{_init_pid} eq "$$.$_tid" ) { $_MCE->{$_pkg}->shutdown(@_) if $_MCE->{$_pkg}{_spawned}; $_gather_ref = $_order_id = undef, undef %_tmp; delete $_user_tasks->{$_pkg}; delete $_prev_c->{$_pkg}; delete $_prev_m->{$_pkg}; delete $_prev_n->{$_pkg}; delete $_prev_w->{$_pkg}; delete $_MCE->{$_pkg}; if (defined $_queue->{$_pkg}) { local $_; $_->DESTROY() for (@{ $_queue->{$_pkg} }); delete $_queue->{$_pkg}; } } @_ = (); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Parallel stream with MCE -- file. ## ############################################################################### sub run_file (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Stream'); my ($_file, $_pos); my $_start_pos = (ref $_[0] eq 'HASH') ? 2 : 1; my $_pid = "$$.$_tid.".caller(); if (defined (my $_p = $_params->{$_pid})) { delete $_p->{input_data} if (exists $_p->{input_data}); delete $_p->{sequence} if (exists $_p->{sequence}); } else { $_params->{$_pid} = {}; } for my $_i ($_start_pos .. @_ - 1) { my $_r = ref $_[$_i]; if ($_r eq '' || $_r eq 'SCALAR' || $_r =~ /^(?:GLOB|FileHandle|IO::)/) { $_file = $_[$_i]; $_pos = $_i; last; } } if (defined $_file && ref $_file eq '' && $_file ne '') { _croak("$_tag: ($_file) does not exist") unless (-e $_file); _croak("$_tag: ($_file) is not readable") unless (-r $_file); _croak("$_tag: ($_file) is not a plain file") unless (-f $_file); $_params->{$_pid}{_file} = $_file; } elsif (ref $_file eq 'SCALAR' || ref($_file) =~ /^(?:GLOB|FileHandle|IO::)/) { $_params->{$_pid}{_file} = $_file; } else { _croak("$_tag: (file) is not specified or valid"); } if (defined $_pos) { pop @_ for ($_pos .. @_ - 1); } return run(@_); } ############################################################################### ## ---------------------------------------------------------------------------- ## Parallel stream with MCE -- sequence. ## ############################################################################### sub run_seq (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Stream'); my ($_begin, $_end, $_pos); my $_start_pos = (ref $_[0] eq 'HASH') ? 2 : 1; my $_pid = "$$.$_tid.".caller(); if (defined (my $_p = $_params->{$_pid})) { delete $_p->{sequence} if (exists $_p->{sequence}); delete $_p->{input_data} if (exists $_p->{input_data}); delete $_p->{_file} if (exists $_p->{_file}); } else { $_params->{$_pid} = {}; } for my $_i ($_start_pos .. @_ - 1) { my $_ref = ref $_[$_i]; if ($_ref eq '' || $_ref eq 'HASH' || $_ref eq 'ARRAY') { $_pos = $_i; if ($_ref eq '') { $_begin = $_[$_pos]; $_end = $_[$_pos + 1]; $_params->{$_pid}{sequence} = [ $_[$_pos], $_[$_pos + 1], $_[$_pos + 2], $_[$_pos + 3] ]; } elsif ($_ref eq 'HASH') { $_begin = $_[$_pos]->{begin}; $_end = $_[$_pos]->{end}; $_params->{$_pid}{sequence} = $_[$_pos]; } elsif ($_ref eq 'ARRAY') { $_begin = $_[$_pos]->[0]; $_end = $_[$_pos]->[1]; $_params->{$_pid}{sequence} = $_[$_pos]; } last; } } _croak("$_tag: (sequence) is not specified or valid") unless (exists $_params->{$_pid}{sequence}); _croak("$_tag: (begin) is not specified for sequence") unless (defined $_begin); _croak("$_tag: (end) is not specified for sequence") unless (defined $_end); $_params->{$_pid}{sequence_run} = 1; if (defined $_pos) { pop @_ for ($_pos .. @_ - 1); } return run(@_); } ############################################################################### ## ---------------------------------------------------------------------------- ## Parallel stream with MCE. ## ############################################################################### sub run (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Stream'); my $_pkg = caller() eq 'MCE::Stream' ? caller(1) : caller(); my $_pid = "$$.$_tid.$_pkg"; if (ref $_[0] eq 'HASH' && !exists $_[0]->{code}) { $_params->{$_pid} = {} unless defined $_params->{$_pid}; for my $_p (keys %{ $_[0] }) { $_params->{$_pid}{$_p} = $_[0]->{$_p}; } shift; } my $_aref; $_aref = shift if (ref $_[0] eq 'ARRAY'); $_order_id = 1; undef %_tmp; if (defined $_aref) { $_gather_ref = $_aref; @{ $_aref } = (); } else { $_gather_ref = undef; } ## ------------------------------------------------------------------------- my (@_code, @_mode, @_name, @_wrks); my $_init_mce = 0; my $_pos = 0; my $_default_mode = $_def->{$_pkg}{DEFAULT_MODE}; while (ref $_[0] eq 'CODE' || ref $_[0] eq 'HASH') { if (ref $_[0] eq 'CODE') { push @_code, $_[0]; push @_mode, $_default_mode; } else { push @_code, exists $_[0]->{code} ? $_[0]->{code} : undef; push @_mode, exists $_[0]->{mode} ? $_[0]->{mode} : $_default_mode; unless (ref $_code[-1] eq 'CODE') { @_ = (); _croak("$_tag: (code) is not valid"); } if ($_mode[-1] ne 'grep' && $_mode[-1] ne 'map') { @_ = (); _croak("$_tag: (mode) is not valid"); } } if (defined (my $_p = $_params->{$_pid})) { push @_name, (ref $_p->{task_name} eq 'ARRAY') ? $_p->{task_name}->[$_pos] : undef; push @_wrks, (ref $_p->{max_workers} eq 'ARRAY') ? $_p->{max_workers}->[$_pos] : undef; } $_init_mce = 1 if ( !defined $_prev_c->{$_pid}[$_pos] || $_prev_c->{$_pid}[$_pos] != $_code[$_pos] ); $_init_mce = 1 if ( !defined $_prev_m->{$_pid}[$_pos] || $_prev_m->{$_pid}[$_pos] ne $_mode[$_pos] ); $_init_mce = 1 if ($_prev_n->{$_pid}[$_pos] ne $_name[$_pos]); $_init_mce = 1 if ($_prev_w->{$_pid}[$_pos] ne $_wrks[$_pos]); $_prev_c->{$_pid}[$_pos] = $_code[$_pos]; $_prev_m->{$_pid}[$_pos] = $_mode[$_pos]; $_prev_n->{$_pid}[$_pos] = $_name[$_pos]; $_prev_w->{$_pid}[$_pos] = $_wrks[$_pos]; shift; $_pos++; } if (defined $_prev_c->{$_pid}[$_pos]) { pop @{ $_prev_c->{$_pid} } for ($_pos .. $#{ $_prev_c->{$_pid } }); pop @{ $_prev_m->{$_pid} } for ($_pos .. $#{ $_prev_m->{$_pid } }); pop @{ $_prev_n->{$_pid} } for ($_pos .. $#{ $_prev_n->{$_pid } }); pop @{ $_prev_w->{$_pid} } for ($_pos .. $#{ $_prev_w->{$_pid } }); $_init_mce = 1; } return unless (scalar @_code); ## ------------------------------------------------------------------------- my $_input_data; my $_max_workers = $_def->{$_pkg}{MAX_WORKERS}; my $_r = ref $_[0]; if ($_r eq 'ARRAY' || $_r eq 'SCALAR' || $_r =~ /^(?:GLOB|FileHandle|IO::)/) { $_input_data = shift if (@_ == 1); } if (defined (my $_p = $_params->{$_pid})) { $_max_workers = MCE::Util::_parse_max_workers($_p->{max_workers}) if (exists $_p->{max_workers} && ref $_p->{max_workers} ne 'ARRAY'); delete $_p->{sequence} if (defined $_input_data || scalar @_); delete $_p->{user_func} if (exists $_p->{user_func}); delete $_p->{user_tasks} if (exists $_p->{user_tasks}); delete $_p->{use_slurpio} if (exists $_p->{use_slurpio}); delete $_p->{bounds_only} if (exists $_p->{bounds_only}); delete $_p->{gather} if (exists $_p->{gather}); } if (@_code > 1 && $_max_workers > 1) { $_max_workers = int($_max_workers / @_code + 0.5) + 1; } my $_chunk_size = MCE::Util::_parse_chunk_size( $_def->{$_pkg}{CHUNK_SIZE}, $_max_workers, $_params->{$_pid}, $_input_data, scalar @_ ); if (defined (my $_p = $_params->{$_pid})) { if (exists $_p->{_file}) { $_input_data = delete $_p->{_file}; } else { $_input_data = $_p->{input_data} if exists $_p->{input_data}; } } ## ------------------------------------------------------------------------- MCE::_save_state(); if ($_init_mce) { $_MCE->{$_pid}->shutdown() if (defined $_MCE->{$_pid}); $_queue->{$_pid} = [] if (!defined $_queue->{$_pid}); my $_Q = $_queue->{$_pid}; pop(@{ $_Q })->DESTROY for (@_code .. @{ $_Q }); push @{ $_Q }, MCE::Queue->new(fast => $_def->{$_pkg}{FAST}) for (@{ $_Q } .. @_code - 2); ## must clear arrays for nested session to work with Perl < v5.14 _gen_user_tasks($_pid, $_Q, [@_code], [@_mode], [@_name], [@_wrks]); @_code = @_mode = @_name = @_wrks = (); my %_opts = ( max_workers => $_max_workers, task_name => $_tag, user_tasks => $_user_tasks->{$_pid}, task_end => \&_task_end, use_slurpio => 0, ); if (defined (my $_p = $_params->{$_pid})) { local $_; for (keys %{ $_p }) { next if ($_ eq 'sequence_run'); next if ($_ eq 'max_workers' && ref $_p->{max_workers} eq 'ARRAY'); next if ($_ eq 'task_name' && ref $_p->{task_name} eq 'ARRAY'); next if ($_ eq 'input_data'); next if ($_ eq 'chunk_size'); next if ($_ eq 'task_end'); _croak("MCE::Stream: ($_) is not a valid constructor argument") unless (exists $MCE::_valid_fields_new{$_}); $_opts{$_} = $_p->{$_}; } } for my $_k (qw/ tmp_dir freeze thaw /) { $_opts{$_k} = $_def->{$_pkg}{uc($_k)} if (exists $_def->{$_pkg}{uc($_k)} && !exists $_opts{$_k}); } $_MCE->{$_pid} = MCE->new(pkg => $_pkg, %_opts); } else { ## Workers may persist after running. Thus, updating the MCE instance. ## These options do not require respawning. if (defined (my $_p = $_params->{$_pid})) { for my $_k (qw( RS interval stderr_file stdout_file user_error user_output job_delay submit_delay on_post_exit on_post_run user_args flush_file flush_stderr flush_stdout max_retries )) { $_MCE->{$_pid}{$_k} = $_p->{$_k} if (exists $_p->{$_k}); } } } ## ------------------------------------------------------------------------- if (defined $_input_data) { @_ = (); $_MCE->{$_pid}->process({ chunk_size => $_chunk_size }, $_input_data); delete $_MCE->{$_pid}{input_data}; } elsif (scalar @_) { $_MCE->{$_pid}->process({ chunk_size => $_chunk_size }, \@_); delete $_MCE->{$_pid}{input_data}; } else { if (defined $_params->{$_pid} && exists $_params->{$_pid}{sequence}) { $_MCE->{$_pid}->run({ chunk_size => $_chunk_size, sequence => $_params->{$_pid}{sequence} }, 0); if (exists $_params->{$_pid}{sequence_run}) { delete $_params->{$_pid}{sequence_run}; delete $_params->{$_pid}{sequence}; } delete $_MCE->{$_pid}{sequence}; } } MCE::_restore_state(); # auto-shutdown if in eval state if ($^S || $ENV{'PERL_IPERL_RUNNING'}) { if (!$INC{'Mojo/IOLoop.pm'} && !$INC{'Tk.pm'}) { $_MCE->{$_pid}->shutdown(); $_->DESTROY() for @{ $_queue->{$_pid} }; delete $_queue->{$_pid}; } } return map { @{ $_ } } delete @_tmp{ 1 .. $_order_id - 1 } unless (defined $_aref); $_gather_ref = undef; return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Private methods. ## ############################################################################### sub _croak { goto &MCE::_croak; } sub _gen_user_tasks { my ($_pid, $_queue_ref, $_code_ref, $_mode_ref, $_name_ref, $_wrks_ref) = @_; @{ $_user_tasks->{$_pid} } = (); ## For the code block farthest to the right. push @{ $_user_tasks->{$_pid} }, { task_name => $_name_ref->[-1], max_workers => $_wrks_ref->[-1], gather => (@{ $_code_ref } > 1) ? $_queue_ref->[-1] : \&_preserve_order, user_func => sub { my ($_mce, $_chunk_ref, $_chunk_id) = @_; my @_a; my $_code = $_code_ref->[-1]; if (ref $_chunk_ref) { push @_a, ($_mode_ref->[-1] eq 'map') ? map { &{ $_code } } @{ $_chunk_ref } : grep { &{ $_code } } @{ $_chunk_ref }; } else { push @_a, ($_mode_ref->[-1] eq 'map') ? map { &{ $_code } } $_chunk_ref : grep { &{ $_code } } $_chunk_ref; } MCE->gather( (@{ $_code_ref } > 1) ? MCE->freeze([ \@_a, $_chunk_id ]) : (\@_a, $_chunk_id) ); } }; ## For in-between code blocks (processed from right to left). for (my $_i = @{ $_code_ref } - 2; $_i > 0; $_i--) { my $_pos = $_i; push @{ $_user_tasks->{$_pid} }, { task_name => $_name_ref->[$_pos], max_workers => $_wrks_ref->[$_pos], gather => $_queue_ref->[$_pos - 1], user_func => sub { my $_q = $_queue_ref->[$_pos]; while (1) { my $_chunk = $_q->dequeue; last unless (defined $_chunk); my @_a; my $_code = $_code_ref->[$_pos]; $_chunk = MCE->thaw($_chunk); push @_a, ($_mode_ref->[$_pos] eq 'map') ? map { &{ $_code } } @{ $_chunk->[0] } : grep { &{ $_code } } @{ $_chunk->[0] }; MCE->gather(MCE->freeze([ \@_a, $_chunk->[1] ])); } return; } }; } ## For the left-most code block. if (@{ $_code_ref } > 1) { push @{ $_user_tasks->{$_pid} }, { task_name => $_name_ref->[0], max_workers => $_wrks_ref->[0], gather => \&_preserve_order, user_func => sub { my $_q = $_queue_ref->[0]; while (1) { my $_chunk = $_q->dequeue; last unless (defined $_chunk); my @_a; my $_code = $_code_ref->[0]; $_chunk = MCE->thaw($_chunk); push @_a, ($_mode_ref->[0] eq 'map') ? map { &{ $_code } } @{ $_chunk->[0] } : grep { &{ $_code } } @{ $_chunk->[0] }; MCE->gather(\@_a, $_chunk->[1]); } return; } }; } return; } sub _validate_number { my ($_n, $_key) = @_; _croak("$_tag: ($_key) is not valid") if (!defined $_n); $_n =~ s/K\z//i; $_n =~ s/M\z//i; if (!looks_like_number($_n) || int($_n) != $_n || $_n < 1) { _croak("$_tag: ($_key) is not valid"); } return; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Stream - Parallel stream model for chaining multiple maps and greps =head1 VERSION This document describes MCE::Stream version 1.810 =head1 SYNOPSIS ## Exports mce_stream, mce_stream_f, mce_stream_s use MCE::Stream; my (@m1, @m2, @m3); ## Default mode is map and processed from right-to-left @m1 = mce_stream sub { $_ * 3 }, sub { $_ * 2 }, 1..10000; mce_stream \@m2, sub { $_ * 3 }, sub { $_ * 2 }, 1..10000; ## Native Perl @m3 = map { $_ * $_ } grep { $_ % 5 == 0 } 1..10000; ## Streaming grep and map in parallel mce_stream \@m3, { mode => 'map', code => sub { $_ * $_ } }, { mode => 'grep', code => sub { $_ % 5 == 0 } }, 1..10000; ## Array or array_ref my @a = mce_stream sub { $_ * $_ }, 1..10000; my @b = mce_stream sub { $_ * $_ }, [ 1..10000 ]; ## File_path, glob_ref, or scalar_ref my @c = mce_stream_f sub { chomp; $_ }, "/path/to/file"; my @d = mce_stream_f sub { chomp; $_ }, $file_handle; my @e = mce_stream_f sub { chomp; $_ }, \$scalar; ## Sequence of numbers (begin, end [, step, format]) my @f = mce_stream_s sub { $_ * $_ }, 1, 10000, 5; my @g = mce_stream_s sub { $_ * $_ }, [ 1, 10000, 5 ]; my @h = mce_stream_s sub { $_ * $_ }, { begin => 1, end => 10000, step => 5, format => undef }; =head1 DESCRIPTION This module allows one to stream multiple map and/or grep operations in parallel. Code blocks run simultaneously from right-to-left. The results are appended immediately when providing a reference to an array. ## Appends are serialized, even out-of-order ok, but immediately. ## Out-of-order chunks are held temporarily until ordered chunks ## arrive. mce_stream \@a, sub { $_ }, sub { $_ }, sub { $_ }, 1..10000; ## input ## chunk1 input ## chunk3 chunk2 input ## chunk2 chunk2 chunk3 input ## append1 chunk3 chunk1 chunk4 input ## append2 chunk1 chunk5 chunk5 input ## append3 chunk5 chunk4 chunk6 ... ## append4 chunk4 chunk6 ... ## append5 chunk6 ... ## append6 ... ## ... ## MCE incurs a small overhead due to passing of data. A fast code block will run faster natively when chaining multiple map functions. However, the overhead will likely diminish as the complexity increases for the code. ## 0.334 secs -- baseline using the native map function my @m1 = map { $_ * 4 } map { $_ * 3 } map { $_ * 2 } 1..1000000; ## 0.427 secs -- this is quite amazing considering data passing my @m2 = mce_stream sub { $_ * 4 }, sub { $_ * 3 }, sub { $_ * 2 }, 1..1000000; ## 0.355 secs -- appends to @m3 immediately, not after running my @m3; mce_stream \@m3, sub { $_ * 4 }, sub { $_ * 3 }, sub { $_ * 2 }, 1..1000000; Even faster is mce_stream_s; useful when input data is a range of numbers. Workers generate sequences mathematically among themselves without any interaction from the manager process. Two arguments are required for mce_stream_s (begin, end). Step defaults to 1 if begin is smaller than end, otherwise -1. ## 0.278 secs -- numbers are generated mathematically via sequence my @m4; mce_stream_s \@m4, sub { $_ * 4 }, sub { $_ * 3 }, sub { $_ * 2 }, 1, 1000000; =head1 OVERRIDING DEFAULTS The following list options which may be overridden when loading the module. use Sereal qw( encode_sereal decode_sereal ); use CBOR::XS qw( encode_cbor decode_cbor ); use JSON::XS qw( encode_json decode_json ); use MCE::Stream max_workers => 8, # Default 'auto' chunk_size => 500, # Default 'auto' tmp_dir => "/path/to/app/tmp", # $MCE::Signal::tmp_dir freeze => \&encode_sereal, # \&Storable::freeze thaw => \&decode_sereal, # \&Storable::thaw default_mode => 'grep', # Default 'map' fast => 1 # Default 0 (fast dequeue) ; From MCE 1.8 onwards, Sereal 3.008+ is loaded automatically if available. Specify C 0> to use Storable instead. use MCE::Stream Sereal => 0; =head1 CUSTOMIZING MCE =over 3 =item MCE::Stream->init ( options ) =item MCE::Stream::init { options } The init function accepts a hash of MCE options. The gather and bounds_only options, if specified, are ignored due to being used internally by the module (not shown below). use MCE::Stream; MCE::Stream::init { chunk_size => 1, max_workers => 4, user_begin => sub { print "## ", MCE->wid, " started\n"; }, user_end => sub { print "## ", MCE->wid, " completed\n"; } }; my @a = mce_stream sub { $_ * $_ }, 1..100; print "\n", "@a", "\n"; -- Output ## 1 started ## 2 started ## 3 started ## 4 started ## 3 completed ## 1 completed ## 2 completed ## 4 completed 1 4 9 16 25 36 49 64 81 100 121 144 169 196 225 256 289 324 361 400 441 484 529 576 625 676 729 784 841 900 961 1024 1089 1156 1225 1296 1369 1444 1521 1600 1681 1764 1849 1936 2025 2116 2209 2304 2401 2500 2601 2704 2809 2916 3025 3136 3249 3364 3481 3600 3721 3844 3969 4096 4225 4356 4489 4624 4761 4900 5041 5184 5329 5476 5625 5776 5929 6084 6241 6400 6561 6724 6889 7056 7225 7396 7569 7744 7921 8100 8281 8464 8649 8836 9025 9216 9409 9604 9801 10000 =back Like with MCE::Stream::init above, MCE options may be specified using an anonymous hash for the first argument. Notice how both max_workers and task_name can take an anonymous array for setting values uniquely per each code block. Remember that MCE::Stream processes from right-to-left when setting the individual values. use MCE::Stream; my @a = mce_stream { task_name => [ 'c', 'b', 'a' ], max_workers => [ 2, 4, 3, ], user_end => sub { my ($mce, $task_id, $task_name) = @_; print "$task_id - $task_name completed\n"; }, task_end => sub { my ($mce, $task_id, $task_name) = @_; MCE->print("$task_id - $task_name ended\n"); } }, sub { $_ * 4 }, ## 2 workers, named c sub { $_ * 3 }, ## 4 workers, named b sub { $_ * 2 }, 1..10000; ## 3 workers, named a -- Output 0 - a completed 0 - a completed 0 - a completed 0 - a ended 1 - b completed 1 - b completed 1 - b completed 1 - b completed 1 - b ended 2 - c completed 2 - c completed 2 - c ended Note that the anonymous hash, for specifying options, also comes first when passing an array reference. my @a; mce_stream { ... }, \@a, sub { ... }, sub { ... }, 1..10000; =head1 API DOCUMENTATION Scripts using MCE::Stream can be written using the long or short form. The long form becomes relevant when mixing modes. Again, processing occurs from right-to-left. my @m3 = mce_stream { mode => 'map', code => sub { $_ * $_ } }, { mode => 'grep', code => sub { $_ % 5 == 0 } }, 1..10000; my @m4; mce_stream \@m4, { mode => 'map', code => sub { $_ * $_ } }, { mode => 'grep', code => sub { $_ % 5 == 0 } }, 1..10000; For multiple grep blocks, the short form can be used. Simply specify the default mode for the module. The two valid values for default_mode is 'grep' and 'map'. use MCE::Stream default_mode => 'grep'; my @f = mce_stream_f sub { /ending$/ }, sub { /^starting/ }, $file; The following assumes 'map' for default_mode in order to demonstrate all the possibilities of passing input data into the code block. =over 3 =item MCE::Stream->run ( { input_data => iterator }, sub { code } ) =item mce_stream { input_data => iterator }, sub { code } An iterator reference can by specified for input_data. The only other way is to specify input_data via MCE::Stream::init. This prevents MCE::Stream from configuring the iterator reference as another user task which will not work. Iterators are described under "SYNTAX for INPUT_DATA" at L. MCE::Stream::init { input_data => iterator }; my @a = mce_stream sub { $_ * 3 }, sub { $_ * 2 }; =item MCE::Stream->run ( sub { code }, list ) =item mce_stream sub { code }, list Input data can be defined using a list. my @a = mce_stream sub { $_ * 2 }, 1..1000; my @b = mce_stream sub { $_ * 2 }, [ 1..1000 ]; =item MCE::Stream->run_file ( sub { code }, file ) =item mce_stream_f sub { code }, file The fastest of these is the /path/to/file. Workers communicate the next offset position among themselves without any interaction from the manager process. my @c = mce_stream_f sub { chomp; $_ . "\r\n" }, "/path/to/file"; my @d = mce_stream_f sub { chomp; $_ . "\r\n" }, $file_handle; my @e = mce_stream_f sub { chomp; $_ . "\r\n" }, \$scalar; =item MCE::Stream->run_seq ( sub { code }, $beg, $end [, $step, $fmt ] ) =item mce_stream_s sub { code }, $beg, $end [, $step, $fmt ] Sequence can be defined as a list, an array reference, or a hash reference. The functions require both begin and end values to run. Step and format are optional. The format is passed to sprintf (% may be omitted below). my ($beg, $end, $step, $fmt) = (10, 20, 0.1, "%4.1f"); my @f = mce_stream_s sub { $_ }, $beg, $end, $step, $fmt; my @g = mce_stream_s sub { $_ }, [ $beg, $end, $step, $fmt ]; my @h = mce_stream_s sub { $_ }, { begin => $beg, end => $end, step => $step, format => $fmt }; =back =head1 MANUAL SHUTDOWN =over 3 =item MCE::Stream->finish =item MCE::Stream::finish Workers remain persistent as much as possible after running. Shutdown occurs automatically when the script terminates. Call finish when workers are no longer needed. use MCE::Stream; MCE::Stream::init { chunk_size => 20, max_workers => 'auto' }; my @a = mce_stream { ... } 1..100; MCE::Stream::finish; =back =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.810/Copying0000644000175000017500000003053113006204541012457 0ustar mariomario GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it!