MCE-1.901/000755 000765 000024 00000000000 14735611252 012410 5ustar00mariostaff000000 000000 MCE-1.901/LICENSE000644 000765 000024 00000014257 13006204541 013413 0ustar00mariostaff000000 000000 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.901/bin/000755 000765 000024 00000000000 14735611252 013160 5ustar00mariostaff000000 000000 MCE-1.901/Changes000644 000765 000024 00000225503 14735610715 013715 0ustar00mariostaff000000 000000 Revision history for Perl module MCE. 1.901 Thu Jan 02 17:30:00 EST 2024 * Add MCE::Core package for future development. 1.900 Mon Sep 09 20:30:00 EST 2024 * Improve MCE::Child exiting when signaled. 1.899 Fri Sep 06 00:15:00 EST 2024 * Fix for MCE::Child and MCE::Channel signal anomaly #24. Thank you, @exodist. 1.898 Wed Aug 21 15:30:00 EST 2024 * Fix for MCE::Child #22, Can't call method "len" on an undefined value during global destruction. Thanks, @exodist. 1.897 Wed Jun 19 22:00:00 EST 2024 * In scalar context, the init function in MCE Child and models Flow, Grep, Loop, Map, Step, and Stream returns a guard to call finish automatically upon leaving the { scope i.e. omitting finish }. * Add out_iter_callback to MCE::Candy. 1.896 Tue Jun 11 16:00:00 EST 2024 * Weaken internal core MCE reference to reap workers automatically upon leaving the { scope i.e. omitting shutdown }. Note: No change to MCE models Flow, Grep, Loop, Map, Step, and Stream. Call finish explicitly to reap workers. This resolves the case when omitting calling either one of $mce->run(), $mce->run(1), or $mce->shutdown() inside a scope, causing workers to linger around until completion of the script. 1.895 Sun Jun 09 01:00:00 EST 2024 * Revert back to calling CORE::rand() to set the internal seed. MCE and MCE::Child cannot assume the srand or setter function used by the application for predictability. 1. https://perlmonks.org/?node_id=11159834 2. https://perlmonks.org/?node_id=11159827 * Add class methods MCE->seed and MCE::Child->seed to retrieve the seed. 1.894 Sun Jun 09 15:30:00 EST 2024 * Improve support for PDL. 1.893 Sat Jun 08 08:30:00 EST 2024 * Preserve functionality for older Perl, non-threads. 1.892 Sat Jun 08 08:00:00 EST 2024 * Remove check if spinning threads i.e. use_threads. Predictable output matches non-threads for CORE, Math::Prime::Util, and Math::Random::MT::Auto. https://perlmonks.org/?node_id=11159834 1.891 Fri Jun 06 04:00:00 EST 2024 * Apply workaround for PDL::srand in MCE and MCE::Child. Thank you, PerlMonks. https://www.perlmonks.org/?node_id=11159773 * Add PDL::srand (v2.062 ~ v2.089) and PDL::srandom (v2.089_01+). * Call CORE::srand inside child processes, only. 1.890 Fri May 24 19:00:00 EST 2024 * Improve reaping completed workers in MCE::Child. * Fix the _sprintf function, failing multiple arguments. 1.889 Wed Sep 13 18:00:00 EST 2023 * Add Android support. Thank you, Dimitrios Kechagias. * Revert defer signal-handling in MCE::Channel (send2 method). * Improve mutex synchronize (aka enter) with guard capability. Thank you, José Joaquín Atria. * Fix mutex re-entrant lock on the Windows platform. * Add mutex guard_lock method. 1.888 Wed Jun 21 17:00:00 EST 2023 * Fix typos caught by lintian. Thank you, Étienne Mollier. 1.887 Fri Jun 09 08:00:00 EST 2023 * Fix typo in Queue dequeue_timed documentation. Thank you, Łukasz Strzelecki. 1.886 Tue Jun 06 12:00:00 EST 2023 * Added dequeue_timed method to MCE::Queue. * Fixed taint mode in MCE->printf and _sprintf. * Improved reliability on the Windows platform. 1.885 Tue May 30 20:00:00 EST 2023 * Improved reliability on the Windows platform. 1.884 Thu Jan 05 10:00:00 EST 2023 * Disabled non-blocking dequeue_nb and recv_nb tests on the Windows platform. Reason: Author cannot reproduce failing tests reported by CPAN Tester aero. Copied nb tests to xt folder: nonblocking_channel.t and nonblocking_queue.t 1.883 Tue Jan 03 20:00:00 EST 2023 * Fix typo in MCE::Channel::SimpleFast documentation. * Improve 05_mce_child.t test. 1.882 Fri Dec 02 21:00:00 EST 2022 * Added ABRT to the list of signals to trap in MCE::Signal. * Added a guard to MCE::Core::Worker for checking if exited prematurely. * Added init_relay and use_threads import options to MCE and MCE Models. * Separated input mutexes from the rest of IPC for lesser latency. * Auto-detect if init_relay is defined and set chunk_size to 1 in MCE::Grep, MCE::Map, and MCE::Stream. * Update the import function in MCE models, detecting if the caller is another MCE module, to not export model functions. * Update the error status if MCE::Child died due to receiving a signal. * Improved reaping in MCE::Child, before creating a new child. * Improved the timeout handler in MCE::Child and MCE::Mutex::Channel. * Fixed private functions _quit and _trap not setting the return value. 1.881 Thu Oct 13 23:45:00 EST 2022 * Improved the private _parse_chunk_size function. For better utilization of CPU cores in MCE::Grep, MCE::Map, and MCE::Stream, processing small input sizes. Previously, chunk_size => 'auto' equals 2 minimally. Starting with MCE v1.881, 'auto' equals 1 minimally. 1.880 Mon Oct 10 04:00:00 EST 2022 * Improved reliability on the Windows platform. * Improved MCE::Mutex::Channel::timedwait on the Windows platform. * Improved MCE::Mutex::Channel performance on UNIX platforms. * Resolved edge case in MCE::Child reaching deadlock. 1.879 Tue May 24 05:00:00 EST 2022 * Replace http with https in documentation and meta files. * Call PDL::set_autopthread_targ(1); disables PDL auto-threading. 1.878 Sun Feb 20 06:45:00 EST 2022 * Fix for the fast channel implementations. Thank you, twata for the test report. 1.877 Sun Feb 20 02:30:00 EST 2022 * Improved suppressing the PDL CLONE warning. Piddles should not be naively copied into new threads. * Added fast channel implementations optimized for non-Unicode strings. The main difference is that these lack freeze-thaw serialization. MCE::Channel::MutexFast, MCE::Channel::SimpleFast, and MCE::Channel::ThreadsFast. 1.876 Thu Dec 02 18:00:00 EST 2021 * Allow percentage above 100% for max_workers in MCE. * MCE::Child update. Improved _ordhash. Renamed JOINED to REAPED in code for better clarity. Specify a percentage for max_workers. Added t/05_mce_child_max_workers.t 1.875 Tue Nov 16 04:00:00 EST 2021 * Specify a percentage for max_workers. Thank you, kcott@PerlMonks (Ken) for the idea. https://www.perlmonks.org/?node_id=11134439 * Added t/03_max_workers.t 1.874 Tue Aug 18 16:00:00 EST 2020 * Improved MCE->yield when used together with MCE::Relay. 1.873 Sat Aug 01 16:00:00 EST 2020 * Removed unused variable in MCE::Mutex::Channel. * Fixed typo in prior change log. Replaced "completed" with "feature complete". 1.872 Sun Jun 14 22:30:00 EST 2020 * Added open to required dependencies. * Set default encodings on standard filehandles in tests using UTF-8. * Bumped minimal Perl version to 5.8.1. * Bumped MCE version to 1.872 to align with MCE::Shared. * The MCE project is feature complete. 1.868 Sun May 10 22:00:00 EST 2020 * Completed threads-like detach capability in MCE::Child. * Resolved MCE::Channel failing when calling dequeue multiple times on an ended channel. * MCE->say, MCE->print, and MCE->printf now return 1. 1.867 Sun May 03 18:00:00 EST 2020 * Bug fix for UTF-8 issues during inter-process communication. This update required undoing optimizations specific to scalar args. Essentially, IPC involves serialization for everything going forward. Install Sereal::Encoder and Sereal::Decoder for better performance in Perl 5.8.8+. * MCE options flush_stdout, flush_stderr, and flush_file now default to enabled for the MCE->print, MCE->printf, and MCE->say output routines. * Improved MCE::Child with threads-like detach capability. See POD. * Improved IPC in MCE::Queue with permanent fast-like dequeue including dequeue_nb. Going forward, the fast and barrier options are silently ignored if specified (i.e. no-op). * Improved IPC performance on Linux. 1.866 Sat Feb 08 21:00:00 EST 2020 * Bug fix for restart_worker, race condition introduced in 1.863. Thank you, Oliver Gorwits for reporting the issue. 1.865 Wed Dec 25 18:00:00 EST 2019 * Bug fix for two-way IPC stalling on Windows in MCE::Channel::Threads. See https://www.perlmonks.org/?node_id=11110612 * Remove the check for MSWin32 in MCE::Channel::Mutex. MCE::Channel since the 1st release silently defaults to MCE::Channel::Threads on Windows. * Small tweak to MCE::Signal. 1.864 Wed Dec 04 13:00:00 EST 2019 * Bug fix in MCE::Signal - Shared manager not exiting, introduced in 1.863. * Use monotonic clock if available in MCE->yield and MCE::Child->yield. See https://www.perlmonks.org/?node_id=11109673 1.863 Sun Nov 26 20:00:00 EST 2019 * On Cygwin, silently use Mutex in MCE::Channel when Threads is specified for better performance. * New defer capability in MCE::Signal. This applies to MCE::Shared 1.863. See POD section labled "DEFER SIGNAL" in MCE::Signal. * Reverted $child->exit back to sending the SIGQUIT signal in MCE::Child now that MCE::Shared::Server 1.863 defers signal during IPC. * Improved reliability for spawning MCE and MCE::Child inside threads including nested parallelization, made possible using a global lock $MCE::_GMUTEX. * Updated signal handling in mce-examples/framebuffer on GitHub. 1.862 Wed Sep 18 22:00:00 EST 2019 * Hotfix for 1.861. 1.861 Wed Sep 18 08:30:00 EST 2019 * Hotfix for 1.849-1.860. The edge cases regarding signal handling have been finally resolved for MCE::Child. Thank you, Richard Kelsch for the use case involving ctrl-c. See mce-examples/framebuffer on GitHub. 1.860 Sun Sep 15 20:00:00 EST 2019 * Signal-handling update release. * Localized input and output record separators in MCE::Channel. * IPC safety in MCE::Child during SIGINT and SIGTERM. * Method $child->exit in MCE::Child now sends the SIGINT signal for extra reliability with MCE::Shared (previously SIGQUIT). 1.850 Mon Sep 09 12:30:00 EST 2019 * Bumped version to coincide with the stable MCE::Shared 1.850 release. 1.849 Sun Sep 08 23:30:00 EST 2019 * Fixed edge case in MCE::Child when reaping inside a signal handler. * Added list_pids class method to MCE::Child. 1.848 Tue Sep 03 23:30:00 EST 2019 * Improved IO::All::{ File, Pipe, STDIO } output via MCE->print($io, ...), printf, and say. This resolves a bug introduced in 1.845 when using App::Cmd::Tester to capture output. 1.847 Mon Sep 02 23:30:00 EST 2019 * Obsolete RedHat MCE-1.840-Sereal-deps.patch file. This patch file is no longer needed and finally resolved with this release. * PDL random numbers now unique between threads. Thank you, PerlMonks (vr). See https://www.perlmonks.org/?node_id=1214439. * Replaced "PF_UNIX" with "AF_UNIX" in MCE::Util. 1.846 Mon Aug 26 21:30:00 EST 2019 * Fixed code tags in documentation. Thank you, Mohammad S Anwar. 1.845 Sun Aug 25 22:00:00 EST 2019 * Croak if is_joinable, is_running, or join is called by a non-managed process in MCE::Child. Added LIMITATION section to the documentation. * Improved is_joinable, is_running, list_joinable, and list_running in MCE::Child. Thank you, Philippe Baumgart. * Added example (Consumer requests item) to MCE::Channel documentation. * Support the task_end option regardless if user_tasks is specified. * Support IO::All::{ File, Pipe, STDIO } for input data including output via MCE->print($io, ...), printf, and say. * Support gather => MCE::Candy::out_iter_fh($io) using MCE::Candy. 1.844 Wed Aug 14 21:30:00 EST 2019 * Resolved MCE stalling when specifying max_retries with init_relay. Ditto for loop_timeout with init_relay on UNIX platforms. Thank you, Chris Denley. * Enhanced loop_timeout to handle workers dieing uncontrollably from any user_tasks (i.e. task_id >= 0). Previously, only task_id == 0. * Improved IPC on the Windows platform for edge case when a worker is awaiting input while the manager process is restarting a worker. * MCE, MCE::Child workers exit immediately upon receiving a SIGSEGV signal. This safeguards IPC from stalling inside the manager process. * Enhanced the _wait_one private function in MCE::Child. * Removed Prima from the list for auto-enabling the posix_exit option. Prima (since 1.52) is parallel safe during global cleanup. * Reached 100% Pod coverage. 1.843 Tue Jul 23 22:30:00 EST 2019 * Updated results in MCE::Child (Parallel::ForkManager-like demonstration). * Completed missing interrupt signal-safety for the non-blocking methods in MCE::Channel::Mutex and MCE::Channel::Threads. 1.842 Sun Jul 21 19:00:00 EST 2019 * Fixed race condition abnormalities in MCE::Child. * Added Parallel::ForkManager-like demonstration to MCE::Child. 1.841 Sun Jul 07 23:30:00 EST 2019 * Disabled t/04_channel_threads testing on Unix platforms for Perl less than 5.10.1. Basically, the MCE::Channel::Threads implementation is not supported on older Perls unless the OS vendor applied upstream patches (i.e. works on RedHat/CentOS 5.x running Perl 5.8.x). * Added LIMITATIONS section to MCE::Channel::Threads. 1.840 Sun Jul 07 05:00:00 EST 2019 * Update MCE::Channel POD documentation. 1.839 Sun Jul 07 04:30:00 EST 2019 [NEW FEATURES] * Added MCE::Mutex::Channel2 providing two locks using a single channel. The secondary lock is accessible by calling methods with the '2' suffix. E.g. primary mutex ->lock, ->unlock; secondary mutex ->lock2, ->unlock2 * Added MCE::Channel providing queue-like and two-way communication supporting threads and processes. * Added MCE::Child and compatibility with Perl 5.8. MCE::Child is based on MCE::Hobo, but using MCE::Channel for data retrieval without involving a shared-manager process. * Added MCE::Channel examples { channel1.pl and channel2.pl } using threads and MCE::Child respectively. https://github.com/marioroy/mce-examples/tree/master/chameneos [ENHANCEMENTS] * IPC update; removed unnecessary overhead including private methods _sysseek and _syswrite from MCE::Util (no longer needed). * Improved MCE->do, now callable by workers and the manager process. * Updated MCE::{ Flow, Grep, Loop, Map, Step, and Stream } documentation on passing an array reference versus a list for deeply input data. * Updated and re-organized the top-level MCE documentation, particularly improved clarity for the 'MCE Models' section. * Removed MANIFEST.SKIP. 1.838 Wed Jan 23 08:30:00 EST 2019 * IPC update, raising reliability across multiple platforms. * Improved hack for the Windows platform for nested MCE sessions. * Added _sysread, _sysseek, _syswrite, and _nonblocking to MCE::Util. * Added barrier option to MCE::Queue allowing one to disable. 1.837 Sat Aug 25 13:00:00 EST 2018 * Seeds the Math::Random::MT::Auto generator automatically when present for non-threads, similarly to Math::Random and Math::Prime::Util, to avoid child processes sharing the same seed value as the parent and each other. The new seed is computed using the current seed. 1.836 Mon Jun 25 08:30:00 EST 2018 * Moved validation code from MCE::Util to MCE::Core::Validation. * Applied small optimizations. 1.835 Tue Mar 13 15:00:00 EST 2018 * Added gather and relay demonstrations to MCE::Relay. * Load IO::Handle for extra stability, preventing workers loading uniquely. * Load Net::HTTP and Net::HTTPS before spawning if present LWP::UserAgent. See https://www.perlmonks.org/?node_id=1199760 and https://www.perlmonks.org/?node_id=1199891. 1.834 Tue Jan 23 08:00:00 EST 2018 * Improved Queue await and dequeue performance on the Windows platform. * Added chameneos-redux parallel demonstrations on GitHub: https://github.com/marioroy/mce-examples/tree/master/chameneos 1.833 Thu Dec 28 16:00:00 EST 2017 * Fixed bug with sequence (#10), broken in 1.832. Thank you, @djerius. 1.832 Tue Nov 21 15:30:00 EST 2017 * Added LWP::UserAgent to list for enabling posix_exit. * Improved number-sequence generation for big integers. * Improved wantarray support in MCE::Mutex synchronize. * Removed limit check on chunk_size option. 1.831 Sun Oct 08 20:30:00 EST 2017 * Added STFL (Terminal UI) to list for enabling posix_exit. See https://www.perlmonks.org/?node_id=1200923. * Math::Prime::Util random numbers now unique between MCE workers. See https://www.perlmonks.org/?node_id=1200960. 1.830 Tue Sep 12 17:00:00 EST 2017 [BUG FIXES] * Fixed MCE and MCE::Relay stalling when setting the input record separator. See https://www.perlmonks.org/?node_id=1196701. Thank you, JediWombat. * Fixed bug with dequeue_nb in MCE::Queue (#8). Thank you, @bokutin. * Fixed signal handler (#9). Thank you, @chrisdenley. [ENHANCEMENTS] * Added Coro and Win32::GUI to list for enabling posix_exit. * Added support for Haiku to get_ncpu in MCE::Util. * Allow gathering to a shared array in MCE::Candy. * Improved CPU count on the AIX platform in MCE::Util. * Improved signal handling, including nested parallel-sessions. * Improved running MCE::Hobo inside MCE workers. * Improved running MCE with PDL. * Refactored logic for MCE->do, bi-directional callback feature. * Preserve lexical type for numbers during IPC: MCE->do and MCE::Queue. * No longer loads threads on the Windows platform in MCE::Signal. This enables MCE::Hobo 1.827 to spin faster, including lesser memory consumption. Threads isn't required to run MCE::Hobo. * Removed extra white-space from POD documentation. * Validated MCE on SmartOS. 1.829 Wed May 03 03:00:00 EST 2017 * Reduced memory consumption. 1.828 Fri Apr 28 16:00:00 EST 2017 [BUG FIXES] * Do not enable barrier mode for Queue on the Windows platform. * Fixed MCE::Mutex::Flock, tmp_file missing script name in path. [ENHANCEMENTS] * Added Curses and Prima to list for enabling the posix_exit option. * Allow a hash as input_data: Core API, MCE::{ Flow, Loop, Step }. * Improved API documentation on MCE models with more synopsis. * Enhanced IPC and signal handling. Reduced memory consumption. * Make tmp_dir on demand in MCE::Signal. Ditto for sess_dir in MCE. * Load Fcntl, File::Path, Symbol on demand. 1.827 Wed Apr 05 01:30:00 EST 2017 * Do not enable barrier mode for Queue if constructed inside a thread or by MCE models (e.g. Step, Stream). Ditto for fast => 1 option. * Updated MCE to not croak when running Perl in taint mode via perl -T. Failing -T was MCE::Core::Input::{ Generator, Sequence }, MCE::Signal, and MCE::Util. * Added Denis Fateyev, Felipe Gasper, and Paul Howarth to Credits. 1.826 Sun Apr 02 23:00:00 EST 2017 * Is now safe running MCE with the Wx GUI toolkit (wxWidgets). 1.825 Sun Apr 02 07:00:00 EST 2017 * Updated MCE::Queue. The following provides a comparison for the enhancements made regarding IPC during 1.822 through 1.825, in order to run on machines having "many" cores. I ran with 12, 96, and 192 workers on an 8 core box. A. MCE queue, dequeue 100k items. my $Q = MCE::Queue->new(); $Q->enqueue( 1 .. 100000 ); $Q->end(); MCE 1.608 $Q->enqueue((undef) x 12, 96, or 192); MCE->new( max_workers => 12, 96, or 192, user_func => sub { while ( defined ( my $item = $Q->dequeue ) ) { ; } } )->run(); MCE 1.608: 12 ~ 1.799 secs 96 ~ 8.702 secs 192 ~ 18.083 secs MCE 1.821: ~ 1.450 secs ~ 5.231 secs ~ 8.102 secs MCE 1.825: ~ 0.976 secs ~ 1.067 secs ~ 1.509 secs B. Input file containing 250k lines ( 300 MiB ). MCE->new( input_data => "/dev/shm/file_250k.txt", max_workers => 12, 96, or 192, chunk_size => 1, use_slurpio => 1, user_func => sub { } )->run(); MCE 1.608: 12 ~ 3.605 secs 96 ~ 8.074 secs 192 ~ 8.465 secs MCE 1.821: ~ 3.613 secs ~ 8.058 secs ~ 8.607 secs MCE 1.825: ~ 3.567 secs ~ 2.601 secs ~ 3.199 secs C. Sequence of numbers from 1 to 200k. MCE->new( sequence => [ 1, 200000 ], max_workers => 12, 96, or 192, chunk_size => 1, user_func => sub { } )->run(); MCE 1.608: 12 ~ 1.236 secs 96 ~ 2.922 secs 192 ~ 3.113 secs MCE 1.821: ~ 1.227 secs ~ 2.915 secs ~ 3.106 secs MCE 1.825: ~ 1.250 secs ~ 1.203 secs ~ 1.581 secs * Results were captured on a fast 8 core system running CentOS Linux 7. The thing to take from this is that running many workers "no longer" results in up to 5.6x penalty regarding IPC. 1.824 Sat Apr 01 01:00:00 EST 2017 * Completed validation for running MCE on a box having 100+ cores. * Tuned the number of data-channels for IPC. Set upper limit in MCE::Core::Input::{ Handle and Sequence } to not impact the OS kernel. The result is better performance, yet graceful. 1.823 Fri Mar 31 19:30:00 EST 2017 * Calibrated the number of data-channels for IPC. 1.822 Fri Mar 31 11:00:00 EST 2017 * Check for EINTR during sysread and syswrite. * Improved reliability when running nested MCE sessions. * Updated MCE::Mutex with Channel and Fcntl implementations. * Completed validation for using MCE with 200+ cores. 1.821 Sun Mar 19 04:00:00 EST 2017 * Improved reliability when running MCE with threads. * Added parallel Net::Pcap and Ping demonstrations on GitHub: https://github.com/marioroy/mce-examples/tree/master/network * Optimized 'dequeue' method in MCE::Queue. * Optimized 'synchronize' method in MCE::Mutex. 1.820 Thu Mar 09 02:00:00 EST 2017 * Improved reliability when running MCE inside an eval block. 1.819 Fri Mar 03 23:00:00 EST 2017 * Fixed issue with localizing AUTOFLUSH variable before autoflush handles. Thank you, Charles Hendry for raising the issue. 1.818 Wed Mar 01 22:00:00 EST 2017 * Updated bin/mce_grep for determining chunk level. Ditto for chunk size. Fixed an issue for not seeing STDERR output with '--chunk-level=file'. Added support for zgrep, zegrep, and zfgrep. Thank you, Jeff Rouse. * Changed Sereal to Sereal::Decoder and Sereal::Encoder in recommends section inside Makefile and META files. * Refactored MCE::Queue. Merged local and manager code base into one. Removed t/04_norm_que_local.t and t/04_prio_que_local.t. * Added 'end' method to MCE::Queue. Updated documentation on dequeue and pending. 1.817 Sat Feb 25 02:00:00 EST 2017 * Improved bin/mce_grep. When -r is specified and zero paths are given, start recursively in the current directory versus await data from STDIN. Set chunk-level accordingly to list mode. 1.816 Fri Feb 24 19:00:00 EST 2017 * Revised the description on max_retries in MCE::Core.pod. 1.815 Fri Feb 24 01:00:00 EST 2017 * Fixed divide-by-zero error in MCE->yield. * Refactored code for the interval option by moving the code to the manager process. This allows the manager process to accomodate the next available worker and ready to run. Previoulsy, a worker taking a long time resulted in empty time slots. Thank you, Philippe Baumgart for your patience. * Revised the description on posix_exit in MCE::Core.pod. 1.814 Mon Feb 20 05:30:00 EST 2017 * Enhanced the progress option for use with MCE->process. Updated demonstrations in MCE::Core.pod. 1.813 Thu Feb 16 02:30:00 EST 2017 * Last minute request by Philippe Baumgart (reminder and long overdue). Added progress option, a code block for receiving info on progress made. See MCE::Core.pod for demonstrations accommodating all input data types. 1.812 Tue Feb 14 17:00:00 EST 2017 * Bumped minimum requirement for Sereal to 3.015 when available. Added check ensuring matching version for Encoder and Decoder. 1.811 Mon Feb 13 23:30:00 EST 2017 * Fixed bug in MCE::Queue (dequeue_nb) when queue has zero items. * Applied small optimization in MCE::Core::Input::Sequence and Generator. * Added cross-platform template to MCE::Examples for making an executable. * Removed signal handling for XCPU and XFSZ from MCE::Signal. * Imply posix_exit => 1 if Gearman::XS or Gearman::Util is present during MCE construction. * Added MCE + Gearman demonstrations (xs and non-xs) on GitHub: https://github.com/marioroy/mce-examples/tree/master/gearman_xs https://github.com/marioroy/mce-examples/tree/master/gearman * Changed kilobytes and megabytes to kibiBytes (KiB) and mebiBytes (MiB) respectively inside the documentation. 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 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: https://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 https://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.901/MANIFEST000644 000765 000024 00000003572 14735610427 013553 0ustar00mariostaff000000 000000 Makefile.PL Changes Copying Credits LICENSE MANIFEST META.json META.yml README.md bin/mce_grep lib/MCE.pm lib/MCE.pod lib/MCE/Candy.pm lib/MCE/Channel.pm lib/MCE/Channel/Mutex.pm lib/MCE/Channel/MutexFast.pm lib/MCE/Channel/Simple.pm lib/MCE/Channel/SimpleFast.pm lib/MCE/Channel/Threads.pm lib/MCE/Channel/ThreadsFast.pm lib/MCE/Child.pm lib/MCE/Core.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/Mutex/Channel.pm lib/MCE/Mutex/Channel2.pm lib/MCE/Mutex/Flock.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/01_mutex_channel.t t/01_mutex_channel2.t t/01_mutex_flock.t t/02_do_callback_args.t t/02_do_callback_result.t t/03_chunk_size.t t/03_max_workers.t t/03_user_args.t t/04_norm_que_manager.t t/04_norm_que_worker.t t/04_prio_que_manager.t t/04_prio_que_worker.t t/04_channel_mutex.t t/04_channel_mutex_mp.t t/04_channel_mutexfast.t t/04_channel_mutexfast_mp.t t/04_channel_simple.t t/04_channel_simplefast.t t/04_channel_threads.t t/04_channel_threads_mp.t t/04_channel_threadsfast.t t/04_channel_threadsfast_mp.t t/05_mce_child.t t/05_mce_child_max_workers.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_candy.t t/06_nodata_flow.t t/06_nodata_step.t t/06_relay.t xt/channel_lock.t xt/channel_timedwait.t xt/channel2_lock.t xt/channel2_timedwait.t xt/dequeue_timed.t xt/flock_lock.t xt/nonblocking_channel.t xt/nonblocking_queue.t MCE-1.901/t/000755 000765 000024 00000000000 14735611252 012653 5ustar00mariostaff000000 000000 MCE-1.901/xt/000755 000765 000024 00000000000 14735611252 013043 5ustar00mariostaff000000 000000 MCE-1.901/README.md000644 000765 000024 00000012704 14735610752 013677 0ustar00mariostaff000000 000000 ## Many-Core Engine for Perl This document describes MCE version 1.901. 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 (to include bin/mce_grep) (or) perl Makefile.PL make make test make install This module requires Perl 5.8.1 or later to run. By default, MCE spawns threads on Windows and child processes otherwise on Cygwin and Unix platforms. The use of threads requires that you include threads support prior to loading MCE. processes (or) use threads; (or) use forks; use threads::shared; 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 mostly installed with Perl: bytes constant Carp Errno Fcntl File::Path IO::Handle Scalar::Util Sereal::Decoder 3.015+ (optional) Sereal::Encoder 3.015+ (optional) Socket Storable 2.04+ (default when Sereal isn't available) Test::More 0.45+ (for make test only) Time::HiRes ### Further Reading The Perl MCE module is described at https://metacpan.org/pod/MCE. MCE options are described at [metacpan](https://metacpan.org/pod/MCE::Core). It includes several demonstrations at the end of the page. See also, [MCE::Examples](https://metacpan.org/pod/MCE::Examples). ### Copyright and Licensing Copyright (C) 2012-2024 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 https://www.gnu.org/copyleft/gpl.html. MCE-1.901/Copying000644 000765 000024 00000030531 13006204541 013732 0ustar00mariostaff000000 000000 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! MCE-1.901/META.yml000644 000765 000024 00000007064 14735610752 013674 0ustar00mariostaff000000 000000 --- 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.008001' configure_requires: ExtUtils::MakeMaker: '0' perl: '5.008001' 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.901' MCE::Candy: file: lib/MCE/Candy.pm version: '1.901' MCE::Channel: file: lib/MCE/Channel.pm version: '1.901' MCE::Channel::Mutex: file: lib/MCE/Channel/Mutex.pm version: '1.901' MCE::Channel::MutexFast: file: lib/MCE/Channel/MutexFast.pm version: '1.901' MCE::Channel::Simple: file: lib/MCE/Channel/Simple.pm version: '1.901' MCE::Channel::SimpleFast: file: lib/MCE/Channel/SimpleFast.pm version: '1.901' MCE::Channel::Threads: file: lib/MCE/Channel/Threads.pm version: '1.901' MCE::Channel::ThreadsFast: file: lib/MCE/Channel/ThreadsFast.pm version: '1.901' MCE::Child: file: lib/MCE/Child.pm version: '1.901' MCE::Core: file: lib/MCE/Core.pm version: '1.901' MCE::Core::Input::Generator: file: lib/MCE/Core/Input/Generator.pm version: '1.901' MCE::Core::Input::Handle: file: lib/MCE/Core/Input/Handle.pm version: '1.901' MCE::Core::Input::Iterator: file: lib/MCE/Core/Input/Iterator.pm version: '1.901' MCE::Core::Input::Request: file: lib/MCE/Core/Input/Request.pm version: '1.901' MCE::Core::Input::Sequence: file: lib/MCE/Core/Input/Sequence.pm version: '1.901' MCE::Core::Manager: file: lib/MCE/Core/Manager.pm version: '1.901' MCE::Core::Validation: file: lib/MCE/Core/Validation.pm version: '1.901' MCE::Core::Worker: file: lib/MCE/Core/Worker.pm version: '1.901' MCE::Flow: file: lib/MCE/Flow.pm version: '1.901' MCE::Grep: file: lib/MCE/Grep.pm version: '1.901' MCE::Loop: file: lib/MCE/Loop.pm version: '1.901' MCE::Map: file: lib/MCE/Map.pm version: '1.901' MCE::Mutex: file: lib/MCE/Mutex.pm version: '1.901' MCE::Mutex::Channel: file: lib/MCE/Mutex/Channel.pm version: '1.901' MCE::Mutex::Channel2: file: lib/MCE/Mutex/Channel2.pm version: '1.901' MCE::Mutex::Flock: file: lib/MCE/Mutex/Flock.pm version: '1.901' MCE::Queue: file: lib/MCE/Queue.pm version: '1.901' MCE::Relay: file: lib/MCE/Relay.pm version: '1.901' MCE::Signal: file: lib/MCE/Signal.pm version: '1.901' MCE::Step: file: lib/MCE/Step.pm version: '1.901' MCE::Stream: file: lib/MCE/Stream.pm version: '1.901' MCE::Subs: file: lib/MCE/Subs.pm version: '1.901' MCE::Util: file: lib/MCE/Util.pm version: '1.901' recommends: Sereal::Decoder: '3.015' Sereal::Encoder: '3.015' requires: Carp: '0' Errno: '0' Fcntl: '0' File::Path: '0' Getopt::Long: '0' IO::Handle: '0' Scalar::Util: '0' Socket: '0' Storable: '2.04' Time::HiRes: '0' base: '0' bytes: '0' constant: '0' open: '0' perl: '5.008001' strict: '0' warnings: '0' resources: bugtracker: https://github.com/marioroy/mce-perl/issues homepage: https://github.com/marioroy/mce-perl license: https://dev.perl.org/licenses/ repository: https://github.com/marioroy/mce-perl.git version: '1.901' MCE-1.901/lib/000755 000765 000024 00000000000 14735611252 013156 5ustar00mariostaff000000 000000 MCE-1.901/Makefile.PL000644 000765 000024 00000015372 14735610752 014376 0ustar00mariostaff000000 000000 # Module makefile for MCE (using ExtUtils::MakeMaker) use strict; use warnings; use 5.008001; 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.901', EXE_FILES => [ @exe_files ], NO_META => 1, PREREQ_PM => { 'base' => 0, 'bytes' => 0, 'constant' => 0, 'open' => 0, 'strict' => 0, 'warnings' => 0, 'Carp' => 0, 'Errno' => 0, 'Fcntl' => 0, 'File::Path' => 0, 'Getopt::Long' => 0, 'IO::Handle' => 0, 'Scalar::Util' => 0, 'Socket' => 0, 'Storable' => 2.04, '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' => 'https://dev.perl.org/licenses/', 'repository' => 'https://github.com/marioroy/mce-perl.git' }, 'provides' => { 'MCE' => { 'file' => 'lib/MCE.pm', 'version' => '1.901' }, 'MCE::Candy' => { 'file' => 'lib/MCE/Candy.pm', 'version' => '1.901' }, 'MCE::Channel' => { 'file' => 'lib/MCE/Channel.pm', 'version' => '1.901' }, 'MCE::Channel::Mutex' => { 'file' => 'lib/MCE/Channel/Mutex.pm', 'version' => '1.901' }, 'MCE::Channel::MutexFast' => { 'file' => 'lib/MCE/Channel/MutexFast.pm', 'version' => '1.901' }, 'MCE::Channel::Simple' => { 'file' => 'lib/MCE/Channel/Simple.pm', 'version' => '1.901' }, 'MCE::Channel::SimpleFast' => { 'file' => 'lib/MCE/Channel/SimpleFast.pm', 'version' => '1.901' }, 'MCE::Channel::Threads' => { 'file' => 'lib/MCE/Channel/Threads.pm', 'version' => '1.901' }, 'MCE::Channel::ThreadsFast' => { 'file' => 'lib/MCE/Channel/ThreadsFast.pm', 'version' => '1.901' }, 'MCE::Child' => { 'file' => 'lib/MCE/Child.pm', 'version' => '1.901' }, 'MCE::Core' => { 'file' => 'lib/MCE/Core.pm', 'version' => '1.901' }, 'MCE::Core::Input::Generator' => { 'file' => 'lib/MCE/Core/Input/Generator.pm', 'version' => '1.901' }, 'MCE::Core::Input::Handle' => { 'file' => 'lib/MCE/Core/Input/Handle.pm', 'version' => '1.901' }, 'MCE::Core::Input::Iterator' => { 'file' => 'lib/MCE/Core/Input/Iterator.pm', 'version' => '1.901' }, 'MCE::Core::Input::Request' => { 'file' => 'lib/MCE/Core/Input/Request.pm', 'version' => '1.901' }, 'MCE::Core::Input::Sequence' => { 'file' => 'lib/MCE/Core/Input/Sequence.pm', 'version' => '1.901' }, 'MCE::Core::Manager' => { 'file' => 'lib/MCE/Core/Manager.pm', 'version' => '1.901' }, 'MCE::Core::Validation' => { 'file' => 'lib/MCE/Core/Validation.pm', 'version' => '1.901' }, 'MCE::Core::Worker' => { 'file' => 'lib/MCE/Core/Worker.pm', 'version' => '1.901' }, 'MCE::Flow' => { 'file' => 'lib/MCE/Flow.pm', 'version' => '1.901' }, 'MCE::Grep' => { 'file' => 'lib/MCE/Grep.pm', 'version' => '1.901' }, 'MCE::Loop' => { 'file' => 'lib/MCE/Loop.pm', 'version' => '1.901' }, 'MCE::Map' => { 'file' => 'lib/MCE/Map.pm', 'version' => '1.901' }, 'MCE::Mutex' => { 'file' => 'lib/MCE/Mutex.pm', 'version' => '1.901' }, 'MCE::Mutex::Channel' => { 'file' => 'lib/MCE/Mutex/Channel.pm', 'version' => '1.901' }, 'MCE::Mutex::Channel2' => { 'file' => 'lib/MCE/Mutex/Channel2.pm', 'version' => '1.901' }, 'MCE::Mutex::Flock' => { 'file' => 'lib/MCE/Mutex/Flock.pm', 'version' => '1.901' }, 'MCE::Queue' => { 'file' => 'lib/MCE/Queue.pm', 'version' => '1.901' }, 'MCE::Relay' => { 'file' => 'lib/MCE/Relay.pm', 'version' => '1.901' }, 'MCE::Signal' => { 'file' => 'lib/MCE/Signal.pm', 'version' => '1.901' }, 'MCE::Step' => { 'file' => 'lib/MCE/Step.pm', 'version' => '1.901' }, 'MCE::Stream' => { 'file' => 'lib/MCE/Stream.pm', 'version' => '1.901' }, 'MCE::Subs' => { 'file' => 'lib/MCE/Subs.pm', 'version' => '1.901' }, 'MCE::Util' => { 'file' => 'lib/MCE/Util.pm', 'version' => '1.901' } }, 'prereqs' => { runtime => { recommends => { 'Sereal::Decoder' => '3.015', 'Sereal::Encoder' => '3.015' } } } } ) : () ), (( eval { ExtUtils::MakeMaker->VERSION(6.48) } ) ? ( MIN_PERL_VERSION => 5.008001 ) : () ), INSTALLDIRS => ( ($] < 5.011) ? 'perl' : 'site' ) ); MCE-1.901/Credits000644 000765 000024 00000026577 14231676121 013746 0ustar00mariostaff000000 000000 To RedHat Engineers: Paul Howarth, Denis Fateyev, Near the very end of the 1.8 cycle were several revisions. Each time, an email was sent to you stating that MCE was completed. But each morning, I woke up with a sense that something else was missed. (a) Running MCE and MCE::Shared inside an eval block. (b) Check for EINTR condition during sysread and syswrite. (c) Check the OS while running with ~ 200 workers. (d) Test MCE with the Wx toolkit - wxWidgets. (e) Test MCE and MCE::Shared by running taint mode via perl -T. (f) Validate DESTROY for shared Condvar and Queue objects. (g) Improve MCE::Shared::Handle for non-shared use, was not 100%. Going from 99.7% to 100.0% required so much effort. I am deeply sorry for the many emails sent. Although far away in miles, you were there in keeping me from going insane. For this I thank you. Best, Mario -- ############################################################################### # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # * # ############################################################################### What follows are many people reporting problems, fixes or solutions. More specifically in alphabetical order by last name. Also, not to forget all the people mentioned in the change log. Baumgart, Philippe For trying the MCE interval option and calling MCE->yield. I felt bad for Philippe spending many hours that it caused me to simulate the interval option over and over again. It turns out that there can be unnecessary delays from a worker taking extra time. MCE 1.815 resolves the issue by allowing the next available worker to run versus workers running orderly. Thank you, Philippe for your patience. 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": https://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: https://www.perl.com/article/61/2014/1/21/ Make-your-code-run-faster-with-Perl-s-secret-turbo-module/ Gasper, Felipe For test scripts found in IO::SigGuard. I was able to get MCE::Mutex to fail with similar testing. The result from testing is that MCE too, must check for EINTR during sysread and syswrite operations. The same is true for MCE::Shared. 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. But not to forget the journey during 1.8. So little was known on the hurdles to cross. It's all over now with MCE 1.827 and MCE::Shared 1.823. Š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: 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.901/META.json000644 000765 000024 00000013172 14735610752 014041 0ustar00mariostaff000000 000000 { "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" : "https://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.008001" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0", "perl" : "5.008001" } }, "runtime" : { "recommends" : { "Sereal::Decoder" : "3.015", "Sereal::Encoder" : "3.015" }, "requires" : { "Carp" : "0", "Errno" : "0", "Fcntl" : "0", "File::Path" : "0", "Getopt::Long" : "0", "IO::Handle" : "0", "Scalar::Util" : "0", "Socket" : "0", "Storable" : "2.04", "Time::HiRes" : "0", "base" : "0", "bytes" : "0", "constant" : "0", "open" : "0", "perl" : "5.008001", "strict" : "0", "warnings" : "0" } } }, "provides" : { "MCE" : { "file" : "lib/MCE.pm", "version" : "1.901" }, "MCE::Candy" : { "file" : "lib/MCE/Candy.pm", "version" : "1.901" }, "MCE::Channel" : { "file" : "lib/MCE/Channel.pm", "version" : "1.901" }, "MCE::Channel::Mutex" : { "file" : "lib/MCE/Channel/Mutex.pm", "version" : "1.901" }, "MCE::Channel::MutexFast" : { "file" : "lib/MCE/Channel/MutexFast.pm", "version" : "1.901" }, "MCE::Channel::Simple" : { "file" : "lib/MCE/Channel/Simple.pm", "version" : "1.901" }, "MCE::Channel::SimpleFast" : { "file" : "lib/MCE/Channel/SimpleFast.pm", "version" : "1.901" }, "MCE::Channel::Threads" : { "file" : "lib/MCE/Channel/Threads.pm", "version" : "1.901" }, "MCE::Channel::ThreadsFast" : { "file" : "lib/MCE/Channel/ThreadsFast.pm", "version" : "1.901" }, "MCE::Child" : { "file" : "lib/MCE/Child.pm", "version" : "1.901" }, "MCE::Core" : { "file" : "lib/MCE/Core.pm", "version" : "1.901" }, "MCE::Core::Input::Generator" : { "file" : "lib/MCE/Core/Input/Generator.pm", "version" : "1.901" }, "MCE::Core::Input::Handle" : { "file" : "lib/MCE/Core/Input/Handle.pm", "version" : "1.901" }, "MCE::Core::Input::Iterator" : { "file" : "lib/MCE/Core/Input/Iterator.pm", "version" : "1.901" }, "MCE::Core::Input::Request" : { "file" : "lib/MCE/Core/Input/Request.pm", "version" : "1.901" }, "MCE::Core::Input::Sequence" : { "file" : "lib/MCE/Core/Input/Sequence.pm", "version" : "1.901" }, "MCE::Core::Manager" : { "file" : "lib/MCE/Core/Manager.pm", "version" : "1.901" }, "MCE::Core::Validation" : { "file" : "lib/MCE/Core/Validation.pm", "version" : "1.901" }, "MCE::Core::Worker" : { "file" : "lib/MCE/Core/Worker.pm", "version" : "1.901" }, "MCE::Flow" : { "file" : "lib/MCE/Flow.pm", "version" : "1.901" }, "MCE::Grep" : { "file" : "lib/MCE/Grep.pm", "version" : "1.901" }, "MCE::Loop" : { "file" : "lib/MCE/Loop.pm", "version" : "1.901" }, "MCE::Map" : { "file" : "lib/MCE/Map.pm", "version" : "1.901" }, "MCE::Mutex" : { "file" : "lib/MCE/Mutex.pm", "version" : "1.901" }, "MCE::Mutex::Channel" : { "file" : "lib/MCE/Mutex/Channel.pm", "version" : "1.901" }, "MCE::Mutex::Channel2" : { "file" : "lib/MCE/Mutex/Channel2.pm", "version" : "1.901" }, "MCE::Mutex::Flock" : { "file" : "lib/MCE/Mutex/Flock.pm", "version" : "1.901" }, "MCE::Queue" : { "file" : "lib/MCE/Queue.pm", "version" : "1.901" }, "MCE::Relay" : { "file" : "lib/MCE/Relay.pm", "version" : "1.901" }, "MCE::Signal" : { "file" : "lib/MCE/Signal.pm", "version" : "1.901" }, "MCE::Step" : { "file" : "lib/MCE/Step.pm", "version" : "1.901" }, "MCE::Stream" : { "file" : "lib/MCE/Stream.pm", "version" : "1.901" }, "MCE::Subs" : { "file" : "lib/MCE/Subs.pm", "version" : "1.901" }, "MCE::Util" : { "file" : "lib/MCE/Util.pm", "version" : "1.901" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/marioroy/mce-perl/issues" }, "homepage" : "https://github.com/marioroy/mce-perl", "license" : [ "https://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/marioroy/mce-perl.git" } }, "version" : "1.901" } MCE-1.901/lib/MCE.pm000644 000765 000024 00000205460 14735610752 014133 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## 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.901'; ## no critic (BuiltinFunctions::ProhibitStringyEval) ## no critic (Subroutines::ProhibitSubroutinePrototypes) ## no critic (TestingAndDebugging::ProhibitNoStrict) use Carp (); my ($_has_threads, $_freeze, $_thaw, $_tid, $_oid); BEGIN { local $@; 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"; if ( $] ge '5.008008' && ! $INC{'PDL.pm'} ) { eval 'use Sereal::Encoder 3.015; use Sereal::Decoder 3.015;'; if ( ! $@ ) { my $_encoder_ver = int( Sereal::Encoder->VERSION() ); my $_decoder_ver = int( Sereal::Decoder->VERSION() ); if ( $_encoder_ver - $_decoder_ver == 0 ) { $_freeze = \&Sereal::Encoder::encode_sereal; $_thaw = \&Sereal::Decoder::decode_sereal; } } } if ( ! defined $_freeze ) { require Storable; $_freeze = \&Storable::freeze; $_thaw = \&Storable::thaw; } } use IO::Handle (); use Scalar::Util qw( looks_like_number refaddr reftype weaken ); use Socket qw( SOL_SOCKET SO_RCVBUF ); use Time::HiRes qw( sleep time ); use MCE::Util qw( $LF ); use MCE::Signal (); use MCE::Mutex (); 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. ## Check for >= 64-bit, otherwize fall back to machine's word length. $_que_template = ( ( log(~0+1) / log(2) ) >= 64 ) ? 'Q2' : 'I2'; $_que_read_size = length pack($_que_template, 0, 0); ## Attributes used internally. ## _abort_msg _caller _chn _com_lock _dat_lock _mgr_live _rla_data _seed ## _chunk_id _pids _run_mode _single_dim _thrs _tids _task_wid _wid _wuf ## _exiting _exit_pid _last_sref _total_exited _total_running _total_workers ## _send_cnt _sess_dir _spawned _state _status _task _task_id _wrk_status ## _init_pid _init_total_workers _pids_t _pids_w _pids_c _relayed ## ## _bsb_r_sock _bsb_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 %_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 progress 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 progress ); %_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 user_args )) { *{ $_p } = sub () { my $self = shift; $self = $MCE unless ref($self); return $self->{$_p}; }; } for my $_p (qw( chunk_id seed 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' ); $_p->{INIT_RELAY} = shift, next if ( $_arg eq 'init_relay' ); $_p->{USE_THREADS} = shift, next if ( $_arg eq 'use_threads' ); 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++; ## Instantiate a module-level instance. $MCE = MCE->new( _module_instance => 1, max_workers => 0 ); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Define constants & variables. ## ############################################################################### use constant { # Max data channels. This cannot be greater than 8 on MSWin32. DATA_CHANNELS => 8, # Max GC size. Undef variable when exceeding size. MAX_GC_SIZE => 1024 * 1024 * 64, 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_REF => 'A~REF', # Input << Array ref OUTPUT_G_REF => 'G~REF', # Input << Glob ref OUTPUT_H_REF => 'H~REF', # Input << Hash ref OUTPUT_I_REF => 'I~REF', # Input << Iter ref OUTPUT_A_CBK => 'A~CBK', # Callback w/ multiple args OUTPUT_N_CBK => 'N~CBK', # Callback w/ no args OUTPUT_A_GTR => 'A~GTR', # Gather data 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 OUTPUT_C_NFY => 'C~NFY', # Chunk ID notification OUTPUT_P_NFY => 'P~NFY', # Progress notification OUTPUT_R_NFY => 'R~NFY', # Relay notification OUTPUT_S_DIR => 'S~DIR', # Make/get sess_dir OUTPUT_T_DIR => 'T~DIR', # Make/get tmp_dir OUTPUT_I_DLY => 'I~DLY', # Interval delay 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 REQUEST_HASH => 2, # Worker requests next hash 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 }; my $_mce_count = 0; sub CLONE { $_tid = threads->tid() if $INC{'threads.pm'}; } sub DESTROY { CORE::kill('KILL', $$) if ( $_is_MSWin32 && $MCE::Signal::KILLED ); $_[0]->shutdown(1) if ( $_[0] && $_[0]->{_spawned} && $_[0]->{_init_pid} eq "$$.$_tid" && !$MCE::Signal::KILLED ); return; } END { return unless ( defined $MCE ); my $_pid = $MCE->{_is_thread} ? $$ .'.'. threads->tid() : $$; $MCE->exit if ( exists $MCE->{_wuf} && $MCE->{_pid} eq $_pid ); _end(); } sub _end { 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'}; $MCE = $TOP_HDLR = 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} = undef; 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. ## Called by MCE::{ Flow, Grep, Loop, Map, Step, and Stream }. sub _save_state { $_prev_mce = $MCE; $MCE = $_[0]; return; } sub _restore_state { $_prev_mce->{_wrk_status} = $MCE->{_wrk_status}; $MCE = $_prev_mce; $_prev_mce = undef; return; } ############################################################################### ## ---------------------------------------------------------------------------- ## New instance instantiation. ## ############################################################################### sub _croak { if (MCE->wid == 0 || ! $^S) { $SIG{__DIE__} = \&MCE::Signal::_die_handler; $SIG{__WARN__} = \&MCE::Signal::_warn_handler; } $\ = undef; goto &Carp::croak; } sub _relay (;&) { goto &MCE::relay; } use MCE::Core::Validation (); use MCE::Core::Manager (); use MCE::Core::Worker (); 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; $self{init_relay} = $_def->{$_pkg}{INIT_RELAY} if (exists $_def->{$_pkg}{INIT_RELAY}); $self{use_threads} = $_def->{$_pkg}{USE_THREADS} if (exists $_def->{$_pkg}{USE_THREADS}); 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; } _sendto_fhs_close(); 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}) { 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 ( $^S || $_tid || $INC{'Mojo/IOLoop.pm'} || $INC{'Coro.pm'} || $INC{'LWP/UserAgent.pm'} || $INC{'stfl.pm'} || $INC{'Curses.pm'} || $INC{'CGI.pm'} || $INC{'FCGI.pm'} || $INC{'Tk.pm'} || $INC{'Wx.pm'} || $INC{'Win32/GUI.pm'} || $INC{'Gearman/Util.pm'} || $INC{'Gearman/XS.pm'} ); } ## ------------------------------------------------------------------------- ## Validation. if (defined $self{tmp_dir}) { _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} = 0 unless scalar(keys %{ $_task }); $_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{_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 = ("$$.$_tid" eq $_oid) ? ( $INC{'MCE/Channel.pm'} ? 4 : DATA_CHANNELS ) : 2; 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 > $self{_data_channels}) ? 1 : 0; $self{_lock_chn} = 1 if $INC{'MCE/Child.pm'} || $INC{'MCE/Hobo.pm'}; if ($MCE->{_wid} == 0) { $MCE = \%self; weaken $MCE if (defined wantarray); } 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 $_WIN_LOCK if $_is_MSWin32; # Obtain locks lock $_MCE_LOCK if $_has_threads && $_is_winenv; $MCE::_GMUTEX->lock() if ($_tid && $MCE::_GMUTEX); sleep 0.015 if $_tid; _sendto_fhs_close(); if ($INC{'PDL.pm'}) { local $@; # PDL::IO::Storable is required for serializing piddles. eval 'use PDL::IO::Storable' unless $INC{'PDL/IO/Storable.pm'}; # PDL data should not be naively copied in new threads. eval 'no warnings; sub PDL::CLONE_SKIP { 1 }'; # Disable PDL auto-threading. eval q{ PDL::set_autopthread_targ(1) }; } if ( $INC{'LWP/UserAgent.pm'} && !$INC{'Net/HTTP.pm'} ) { local $@; eval 'require Net::HTTP; require Net::HTTPS'; } ## Start the shared-manager process if not running. 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 =~ /^(?:ARRAY|HASH|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__}; my $_warn_handler = $SIG{__WARN__}; $SIG{__DIE__} = \&MCE::Signal::_die_handler; $SIG{__WARN__} = \&MCE::Signal::_warn_handler; 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); } weaken($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; MCE::Util::_sock_ready($_DAT_W_SOCK, -1); MCE::Util::_sysread($_DAT_W_SOCK, my($_buf), 1); } } ## ------------------------------------------------------------------------- my $_data_channels = $self->{_data_channels}; my $_max_workers = _get_max_workers($self); my $_use_threads = $self->{use_threads}; ## Create [ 0 including 1 up to 8 ] locks for data channels (max 9). $self->{'_mutex_0'} = MCE::Mutex->new( impl => 'Channel' ); if ($self->{_lock_chn}) { $self->{'_mutex_'.$_} = MCE::Mutex->new( impl => 'Channel' ) for (1 .. $_data_channels); } ## Create two locks for use by MCE::Core::Input::{ Handle or Sequence }. $self->{'_mutex_'.$_} = MCE::Mutex->new( impl => 'Channel' ) for (10 .. 11); ## Create sockets for IPC. sync, comm, input, data MCE::Util::_sock_pair($self, qw(_bsb_r_sock _bsb_w_sock), undef, 1); MCE::Util::_sock_pair($self, qw(_com_r_sock _com_w_sock), undef, 1); MCE::Util::_sock_pair($self, qw(_que_r_sock _que_w_sock), undef, 1); MCE::Util::_sock_pair($self, qw(_dat_r_sock _dat_w_sock), 0); MCE::Util::_sock_pair($self, qw(_dat_r_sock _dat_w_sock), $_, 1) for (1 .. $_data_channels); if ($^O !~ /linux|android|aix/) { setsockopt($self->{_dat_r_sock}->[0], SOL_SOCKET, SO_RCVBUF, pack('i', 4096)); } if (defined $self->{init_relay}) { # relay unless ($INC{'MCE/Relay.pm'}) { require MCE::Relay; MCE::Relay->import(); } MCE::Util::_sock_pair($self, qw(_rla_r_sock _rla_w_sock), $_, 1) for (0 .. $_max_workers - 1); } $self->{_seed} = int(CORE::rand() * 1e9); ## ------------------------------------------------------------------------- ## Spawn workers. $self->{_pids} = [], $self->{_thrs} = [], $self->{_tids} = []; $self->{_status} = [], $self->{_state} = [], $self->{_task} = []; if ($self->{loop_timeout} && !$_is_MSWin32) { $self->{_pids_t} = {}, $self->{_pids_w} = {}; } local $SIG{TTIN}, local $SIG{TTOU}, local $SIG{WINCH} unless $_is_MSWin32; 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) { $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}) { $_wid += 1; $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 && refaddr($MCE) != refaddr($self)); $MCE::_GMUTEX->unlock() if ($_tid && $MCE::_GMUTEX); return $self; } ############################################################################### ## ---------------------------------------------------------------------------- ## Process method, relay stubs, and AUTOLOAD for methods not used often. ## ############################################################################### sub process { my $self = shift; $self = $MCE unless ref($self); _validate_runstate($self, 'MCE::process'); my ($_params_ref, $_input_data); if (ref $_[0] eq 'HASH' && ref $_[1] eq 'HASH') { $_params_ref = $_[0], $_input_data = $_[1]; } elsif (ref $_[0] eq 'HASH') { $_params_ref = $_[0], $_input_data = $_[1]; } else { $_params_ref = $_[1], $_input_data = $_[0]; } @_ = (); ## 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 (;&) { _croak('MCE::relay: (init_relay) is not defined') unless (defined $MCE->{init_relay}); } { no warnings 'once'; *relay_unlock = \&relay; } sub AUTOLOAD { # $AUTOLOAD = MCE:: my $_fcn = substr($MCE::AUTOLOAD, 5); my $self = shift; $self = $MCE unless ref($self); # "for" sugar methods if ($_fcn eq 'forchunk') { require MCE::Candy unless $INC{'MCE/Candy.pm'}; return MCE::Candy::forchunk($self, @_); } elsif ($_fcn eq 'foreach') { require MCE::Candy unless $INC{'MCE/Candy.pm'}; return MCE::Candy::foreach($self, @_); } elsif ($_fcn eq 'forseq') { require MCE::Candy unless $INC{'MCE/Candy.pm'}; return MCE::Candy::forseq($self, @_); } # relay stubs for MCE::Relay if ($_fcn eq 'relay_lock' || $_fcn eq 'relay_recv') { _croak('MCE::relay: (init_relay) is not defined') unless (defined $MCE->{init_relay}); } elsif ($_fcn eq 'relay_final') { return; } # worker immediately exits the chunking loop if ($_fcn eq 'last') { _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 elsif ($_fcn eq 'next') { _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, include thread ID for threads elsif ($_fcn eq 'pid') { if (defined $self->{_pid}) { return $self->{_pid}; } elsif ($_has_threads && $self->{use_threads}) { return $$ .'.'. threads->tid(); } return $$; } # return the exit status # _wrk_status holds the greatest exit status among workers exiting elsif ($_fcn eq 'status') { _croak('MCE::status: method is not allowed by the worker process') if ($self->{_wid}); return (defined $self->{_wrk_status}) ? $self->{_wrk_status} : 0; } _croak("Can't locate object method \"$_fcn\" via package \"MCE\""); } ############################################################################### ## ---------------------------------------------------------------------------- ## 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); } delete $self->{_retry_cnt}; if (defined $self->{spawn_delay} && $self->{spawn_delay} > 0.0) { sleep $self->{spawn_delay}; } elsif ($_tid || $_is_MSWin32) { sleep 0.045; } 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} = \&MCE::Signal::_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__} = \&MCE::Signal::_die_handler; local $SIG{__WARN__} = \&MCE::Signal::_warn_handler; $MCE = $self if ($MCE->{_wid} == 0 && refaddr($MCE) != refaddr($self)); 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) = (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; # Previously + 1 above. Below, support for large numbers, 1e16 and beyond. # E.g. sequence => [ 1, 1e16 ], chunk_size => 1e11 # # Perl: int((1e15 - 1) / 1 / 1e11) = 9999 # Perl: int((1e16 - 1) / 1 / 1e11) = 100000 wrong, due to precision limit # Calc: int((1e16 - 1) / 1 / 1e11) = 99999 if ( $_step > 0 ) { $_abort_msg++ if ($_abort_msg * $_chunk_size * abs($_step) + $_begin <= $_end); } else { $_abort_msg++ if ($_abort_msg * $_chunk_size * abs($_step) + $_end <= $_begin); } $_first_msg = 0; } elsif (defined $self->{input_data}) { my $_ref = ref $self->{input_data}; if ($_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) { $self->shutdown() if ($_auto_shutdown == 1); return $self; } } elsif ($_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) { $self->shutdown() if ($_auto_shutdown == 1); return $self; } } elsif ($_ref eq 'HASH') { # Hash mode $_run_mode = 'hash'; $_input_data = $self->{input_data}; $_input_file = $_input_glob = undef; $_abort_msg = 0; ## Flag: Has Data: No $_first_msg = 1; ## Flag: Has Data: Yes if (scalar( keys %{ $_input_data } ) == 0) { $self->shutdown() if ($_auto_shutdown == 1); return $self; } } 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 '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, '_chunk_size' => $_chunk_size, '_input_file' => $_input_file, '_run_mode' => $_run_mode, '_bounds_only' => $self->{bounds_only}, '_max_retries' => $self->{max_retries}, '_parallel_io' => $self->{parallel_io}, '_progress' => $self->{progress} ? 1 : 0, '_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} = undef unless ($self->{_state}[$_i]{_task_id}); } } local $\ = undef; local $/ = $LF; ## Insert the first message into the queue if defined. if (defined $_first_msg) { syswrite($self->{_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), <$_COM_R_SOCK>; $self->{_state}[$_wid]{_params} = \%_params; } else { print({$_COM_R_SOCK} $_frozen_nodata), <$_COM_R_SOCK>; $self->{_state}[$_wid]{_params} = \%_params_nodata; } sleep $_submit_delay if defined($_submit_delay) && $_submit_delay > 0.0; } } ## ------------------------------------------------------------------------- $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->{_bsb_r_sock}, $_buf); } else { my $_BSB_R_SOCK = $self->{_bsb_r_sock}; for my $_i (1 .. $_total_workers) { syswrite($_BSB_R_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') { MCE::Util::_sysread($self->{_que_r_sock}, my($_buf), $_que_read_size) if ( defined $self->{_que_r_sock} ); } $self->{_send_cnt} = 0; ## Shutdown workers. if ($_auto_shutdown || $self->{_total_exited}) { $self->shutdown(); } elsif ($INC{'MCE/Simple.pm'}) { $self->shutdown(); } elsif ($^S || $ENV{'PERL_IPERL_RUNNING'}) { if ( !$INC{'Mojo/IOLoop.pm'} && !$INC{'Win32/GUI.pm'} && !$INC{'Gearman/XS.pm'} && !$INC{'Gearman/Util.pm'} && !$INC{'Tk.pm'} && !$INC{'Wx.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__} = \&MCE::Signal::_die_handler; local $SIG{__WARN__} = \&MCE::Signal::_warn_handler; ## Begin data submission. local $\ = undef; local $/ = $LF; my $_COM_R_SOCK = $self->{_com_r_sock}; 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>; $self->{_send_cnt} += 1; sleep $_submit_delay if defined($_submit_delay) && $_submit_delay > 0.0; return $self; } ############################################################################### ## ---------------------------------------------------------------------------- ## Shutdown method. ## ############################################################################### sub shutdown { my $self = shift; $self = $MCE unless ref($self); my $_no_lock = shift || 0; @_ = (); ## Return unless spawned or already shutdown. return unless $self->{_spawned}; ## Return if signaled. if ($MCE::Signal::KILLED) { if (defined $self->{_sess_dir}) { my $_sess_dir = delete $self->{_sess_dir}; rmdir $_sess_dir if -d $_sess_dir; } return; } _validate_runstate($self, 'MCE::shutdown'); ## Complete processing before shutting down. $self->run(0) if ($self->{_send_cnt}); local $SIG{__DIE__} = \&MCE::Signal::_die_handler; local $SIG{__WARN__} = \&MCE::Signal::_warn_handler; 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}; 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 _com_w_sock _com_r_sock _que_w_sock _que_r_sock _dat_w_sock _dat_r_sock _rla_w_sock _rla_r_sock )); ## ------------------------------------------------------------------------- ## Destroy mutexes. for my $_i (0 .. $_data_channels) { delete $self->{'_mutex_'.$_i}; } for my $_j (10 .. 11) { delete $self->{'_mutex_'.$_j}; } # input mutexes ## Remove session directory. rmdir $_sess_dir if (defined $_sess_dir && -d $_sess_dir); ## Reset instance. undef @{$self->{_pids}}; undef @{$self->{_thrs}}; undef @{$self->{_tids}}; undef @{$self->{_state}}; undef @{$self->{_status}}; undef @{$self->{_task}}; $self->{_chunk_id} = $self->{_send_cnt} = $self->{_spawned} = 0; $self->{_total_running} = $self->{_total_exited} = 0; $self->{_total_workers} = 0; $self->{_sess_dir} = undef; if ($self->{loop_timeout}) { delete $self->{_pids_t}; delete $self->{_pids_w}; } 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 $_BSB_W_SOCK = $self->{_bsb_w_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, -1) if $_is_MSWin32; MCE::Util::_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. MCE::Util::_sock_ready($_BSB_W_SOCK, -1) if $_is_MSWin32; MCE::Util::_sysread($_BSB_W_SOCK, $_buf, 1); return; } sub yield { my $self = shift; $self = $MCE unless ref($self); return 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 $_delay; local $\ = undef if (defined $\); local $/ = $LF if (!$/ || $/ ne $LF); $_DAT_LOCK->lock() if $_lock_chn; print({$_DAT_W_SOCK} OUTPUT_I_DLY.$LF . $_chn.$LF), print({$_DAU_W_SOCK} $self->{_task_id}.$LF); chomp($_delay = <$_DAU_W_SOCK>); $_DAT_LOCK->unlock() if $_lock_chn; MCE::Util::_sleep( $_delay ); } ############################################################################### ## ---------------------------------------------------------------------------- ## Miscellaneous methods: abort exit sess_dir tmp_dir. ## ############################################################################### ## 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) { MCE::Util::_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] : $self->chunk_id; @_ = (); _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}; unless ( $self->{_exiting} ) { $self->{_exiting} = 1; my $_pid = $self->{_is_thread} ? $$ .'.'. threads->tid() : $$; my $_max_retries = $self->{max_retries}; my $_chunk_id = $self->{_chunk_id}; if ( defined $self->{init_relay} && !$self->{_relayed} && !$_task_id && exists $self->{_wuf} && $self->{_pid} eq $_pid ) { $self->{_retry_cnt} = -1 unless defined( $self->{_retry_cnt} ); if ( !$_max_retries || ++$self->{_retry_cnt} == $_max_retries ) { MCE::relay { warn "Error: chunk $_chunk_id failed\n" if $_chunk_id }; } } ## Check for nested workers not yet joined. MCE::Child->finish('MCE') if $INC{'MCE/Child.pm'}; MCE::Hobo->finish('MCE') if ( $INC{'MCE/Hobo.pm'} && MCE::Hobo->can('_clear') ); local $\ = undef if (defined $\); my $_len = length $_exit_msg; $_exit_id =~ s/[\r\n][\r\n]*/ /mg; $_DAT_LOCK->lock() if $_lock_chn; if ($self->{_retry} && $self->{_retry}->[2]--) { $_exit_status = 0; my $_buf = $self->{freeze}($self->{_retry}); 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 . length($_buf).$LF, $_buf ); } else { 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 . '0'.$LF ); } $_DAT_LOCK->unlock() if $_lock_chn; } _exit($self); } ## Return the session dir, made on demand. sub sess_dir { my $self = shift; $self = $MCE unless ref($self); return $self->{_sess_dir} if defined $self->{_sess_dir}; if ($self->{_wid} == 0) { $self->{_sess_dir} = $self->{_spawned} ? _make_sessdir($self) : undef; } else { 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 $_sess_dir; local $\ = undef if (defined $\); local $/ = $LF if (!$/ || $/ ne $LF); $_DAT_LOCK->lock() if $_lock_chn; print({$_DAT_W_SOCK} OUTPUT_S_DIR.$LF . $_chn.$LF); chomp($_sess_dir = <$_DAU_W_SOCK>); $_DAT_LOCK->unlock() if $_lock_chn; $self->{_sess_dir} = $_sess_dir; } } ## Return the temp dir, made on demand. sub tmp_dir { my $self = shift; $self = $MCE unless ref($self); return $self->{tmp_dir} if defined $self->{tmp_dir}; if ($self->{_wid} == 0) { $self->{tmp_dir} = MCE::Signal::_make_tmpdir(); } else { 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 $_tmp_dir; local $\ = undef if (defined $\); local $/ = $LF if (!$/ || $/ ne $LF); $_DAT_LOCK->lock() if $_lock_chn; print({$_DAT_W_SOCK} OUTPUT_T_DIR.$LF . $_chn.$LF); chomp($_tmp_dir = <$_DAU_W_SOCK>); $_DAT_LOCK->unlock() if $_lock_chn; $self->{tmp_dir} = $_tmp_dir; } } ############################################################################### ## ---------------------------------------------------------------------------- ## 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: (code ref) is not supported') if (ref $_[0] eq 'CODE'); _croak('MCE::do: (callback) is not specified') unless (defined ( my $_func = shift )); $_func = $_pkg.'::'.$_func if (index($_func, ':') < 0); if ($self->{_wid}) { return _do_callback($self, $_func, [ @_ ]); } else { no strict 'refs'; return $_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, 'stderr' => SENDTO_STDERR, 'file:' => SENDTO_FILEV2, 'stdout' => SENDTO_STDOUT, '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 = exists $_sendto_lkup{ lc($_to) } ? $_sendto_lkup{ lc($_to) } : undef; my $_value; if (!defined $_dest) { my $_fd; if (ref($_to) && ( defined ($_fd = fileno($_to)) || defined ($_fd = eval { $_to->fileno }) )) { 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); } elsif (reftype($_to) eq 'GLOB') { return _croak('Cannot write to filehandle'); } if (defined $_to && $_to =~ /$_v2_regx/o) { $_dest = exists $_sendto_lkup{ lc($1) } ? $_sendto_lkup{ lc($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); if (ref($_[0]) && ( defined ($_fd = fileno($_[0])) || defined ($_fd = eval { $_[0]->fileno }) )) { 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; } elsif (reftype($_[0]) eq 'GLOB') { return _croak('Cannot write to filehandle'); } $_data = join('', scalar @_ ? @_ : $_); 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 printf { my $self = shift; $self = $MCE unless ref($self); my ($_fd, $_glob, $_fmt, $_data); if (ref($_[0]) && ( defined ($_fd = fileno($_[0])) || defined ($_fd = eval { $_[0]->fileno }) )) { 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; } elsif (reftype($_[0]) eq 'GLOB') { return _croak('Cannot write to filehandle'); } $_fmt = shift || '%s'; $_data = _sprintf($_fmt, scalar @_ ? @_ : $_); 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])) || defined ($_fd = eval { $_[0]->fileno }) )) { 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; } elsif (reftype($_[0]) eq 'GLOB') { return _croak('Cannot write to filehandle'); } $_data = join('', scalar @_ ? @_ : $_) . "\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 _exit { my $self = shift; my $_has_guard = (exists $self->{_guard} && $self->{_guard}->[0]) ? 1 : 0; @{ $self->{_guard} } = () if $_has_guard; delete $self->{_wuf}; _end(); ## Exit thread/child process. $SIG{__DIE__} = sub {} unless $_tid; $SIG{__WARN__} = sub {}; threads->exit(0) if $self->{use_threads}; if (! $_tid) { $SIG{HUP} = $SIG{INT} = $SIG{QUIT} = $SIG{TERM} = sub { $SIG{$_[0]} = $SIG{INT} = $SIG{TERM} = sub {}; CORE::kill($_[0], getppid()) if (($_[0] eq 'INT' || $_[0] eq 'TERM') && $^O ne 'MSWin32'); CORE::kill('KILL', $$); }; } if ($self->{posix_exit} && !$_has_guard && !$_is_MSWin32) { eval { MCE::Mutex::Channel::_destroy() }; POSIX::_exit(0) if $INC{'POSIX.pm'}; 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 _make_sessdir { my $self = shift; $self = $MCE unless ref($self); my $_sess_dir = $self->{_sess_dir}; unless (defined $_sess_dir) { $self->{tmp_dir} = MCE::Signal::_make_tmpdir() unless defined $self->{tmp_dir}; my $_mce_tid = $INC{'threads.pm'} ? threads->tid() : ''; $_mce_tid = '' unless defined $self->{_mce_tid}; my $_mce_sid = $$ .'.'. $_mce_tid .'.'. (++$_mce_count); my $_tmp_dir = $self->{tmp_dir}; _croak("MCE::sess_dir: (tmp_dir) is not defined") if (!defined $_tmp_dir || $_tmp_dir eq ''); _croak("MCE::sess_dir: ($_tmp_dir) is not a directory or does not exist") unless (-d $_tmp_dir); _croak("MCE::sess_dir: ($_tmp_dir) is not writeable") unless (-w $_tmp_dir); my $_cnt = 0; $_sess_dir = "$_tmp_dir/$_mce_sid"; $_sess_dir = "$_tmp_dir/$_mce_sid." . (++$_cnt) while ( !(mkdir $_sess_dir, 0770) ); } return $_sess_dir; } sub _sprintf { my $_fmt = shift; # remove tainted'ness ($_fmt) = $_fmt =~ /(.*)/s; return sprintf("$_fmt", @_); } 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 && ( defined($self->{max_retries}) || $INC{'MCE/Child.pm'} || $INC{'MCE/Hobo.pm'} )); delete $self->{_relayed}; $self->{_is_thread} = $_is_thread; $self->{_pid} = $_is_thread ? $$ .'.'. threads->tid() : $$; if (!$self->{use_threads}) { MCE::Child->_clear() if $INC{'MCE/Child.pm'}; MCE::Hobo->_clear() if $INC{'MCE/Hobo.pm'}; } # Set the seed of the base generator uniquely between workers. # The new seed is computed using the current seed and ID value. # One may set the seed at the application level for predictable # results (non-thread workers only). Ditto for Math::Prime::Util, # Math::Random, Math::Random::MT::Auto, and PDL. # # MCE 1.892, 2024-06-08: Enable predictability running threads. # Output matches non-threads for CORE, Math::Prime::Util, and # Math::Random::MT::Auto. https://perlmonks.org/?node_id=11159834 { my $_wid = $_args[1]; my $_seed = abs($self->{_seed} - ($_wid * 100000)) % 2147483560; CORE::srand($_seed) if (!$self->{use_threads} || $] ge '5.020000'); # drand48 Math::Prime::Util::srand($_seed) if $INC{'Math/Prime/Util.pm'}; # [etj] identified a race condition in PDL running threads # https://perlmonks.org/?node_id=11159841 if (!$self->{use_threads}) { PDL::srand($_seed) if $INC{'PDL.pm'} && PDL->can('srand'); # PDL 2.062 ~ 2.089 PDL::srandom($_seed) if $INC{'PDL.pm'} && PDL->can('srandom'); # PDL 2.089_01+ } } if (!$self->{use_threads} && $INC{'Math/Random.pm'}) { my ($_wid, $_cur_seed) = ($_args[1], Math::Random::random_get_seed()); my $_new_seed = ($_cur_seed < 1073741781) ? $_cur_seed + (($_wid * 100000) % 1073741780) : $_cur_seed - (($_wid * 100000) % 1073741780); Math::Random::random_set_seed($_new_seed, $_new_seed); } if ($INC{'Math/Random/MT/Auto.pm'}) { my ($_wid, $_cur_seed) = ( $_args[1], Math::Random::MT::Auto::get_seed()->[0] ); my $_new_seed = ($_cur_seed < 1073741781) ? $_cur_seed + (($_wid * 100000) % 1073741780) : $_cur_seed - (($_wid * 100000) % 1073741780); Math::Random::MT::Auto::set_seed($_new_seed); } ## Run. _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(); sleep $self->{spawn_delay} if defined($self->{spawn_delay}) && $self->{spawn_delay} > 0.0; 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 ($self->{loop_timeout} && !$_is_MSWin32) { $self->{_pids_t}{$_pid} = $_task_id; $self->{_pids_w}{$_pid} = $_wid; } sleep $self->{spawn_delay} if defined($self->{spawn_delay}) && $self->{spawn_delay} > 0.0; return; } 1; MCE-1.901/lib/MCE/000755 000765 000024 00000000000 14735611252 013562 5ustar00mariostaff000000 000000 MCE-1.901/lib/MCE.pod000644 000765 000024 00000017000 14735610752 014270 0ustar00mariostaff000000 000000 =head1 NAME MCE - Many-Core Engine for Perl providing parallel processing capabilities =head1 VERSION This document describes MCE version 1.901 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 Four modules make up the core engine for MCE. =over 3 =item L This is the POD documentation describing the core Many-Core Engine (MCE) API. Go here for help with the various MCE options. See also, L for additional demonstrations. =item L Provides a simple semaphore implementation supporting threads and processes. Two implementations are provided; one via pipes or socket depending on the platform and the other using Fcntl. =item L Provides signal handling, temporary directory creation, and cleanup for MCE. =item L Provides utility functions for MCE. =back =head1 MCE EXTRAS There are 5 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 Introduced in MCE 1.839, provides queue-like and two-way communication capability. Three implementations C, C, and C are provided. C does not involve locking whereas C and C do locking transparently using C and C respectively. =item L Also introduced in MCE 1.839, provides a threads-like parallelization module that is compatible with Perl 5.8. It is a fork of L. The difference is using a common C object when yielding and joining. =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 Provides workers the ability to receive and pass information orderly with zero involvement by the manager process. This module is loaded automatically by MCE when specifying the C MCE option. =back =head1 MCE MODELS The MCE models are sugar syntax on top of the L API. Two MCE options (chunk_size and max_workers) are configured automatically. Moreover, spawning workers and later shutdown occur transparently behind the scene. Choosing a MCE Model largely depends on the application. It all boils down to how much automation you need MCE to handle transparently. Or if you prefer, constructing the MCE object and running using the core MCE API is fine too. =over 3 =item L Provides a parallel grep implementation similar to the native grep function. =item L Provides a parallel map implementation similar to the native map function. =item L Provides a parallel for loop implementation. =item L Like C, but with support for multiple pools of workers. The pool of workers are configured transparently via the MCE C option. =item L Like C, but adds a C object between each pool of workers. This model, introduced in 1.506, allows one to pass data forward (left to right) from one sub-task into another with little effort. =item L This provides an efficient parallel implementation for chaining multiple maps and greps transparently. Like C and C, it too supports multiple pools of workers. The distinction is that C passes data from right to left and done for you transparently. =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. =head1 SOURCE AND FURTHER READING The source and examples are hosted at GitHub. =over 3 =item * L =item * L =back =head1 SEE ALSO Refer to the L documentation where the API is described. C provides data sharing capabilities for C. It includes C for running code asynchronously with the IPC handled by the shared-manager process. =over 3 =item * L =item * L =back =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =head1 COPYRIGHT AND LICENSE Copyright (C) 2012-2024 by Mario E. Roy MCE is released under the same license as Perl. See L for more information. =cut MCE-1.901/lib/MCE/Examples.pod000644 000765 000024 00000070765 14735610752 016067 0ustar00mariostaff000000 000000 =head1 NAME MCE::Examples - Various examples and demonstrations =head1 VERSION This document describes MCE::Examples version 1.901 =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 # https://benchmarksgame-team.pages.debian.net/benchmarksgame/ # # 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 CROSS-PLATFORM TEMPLATE FOR BINARY EXECUTABLE Making an executable is possible with the L module. On the Windows platform, threads, threads::shared, and exiting via threads are necessary for the binary to exit successfully. # https://metacpan.org/pod/PAR::Packer # https://metacpan.org/pod/pp # # pp -o demo.exe demo.pl # ./demo.exe use strict; use warnings; use if $^O eq "MSWin32", "threads"; use if $^O eq "MSWin32", "threads::shared"; use Time::HiRes (); # include minimum dependencies for MCE use Storable (); use IO::FDPass (); # optional: for MCE::Shared->condvar, handle, queue use Sereal (); # optional: faster serialization, may omit Storable use MCE; my $mce = MCE->new( max_workers => 4, user_func => sub { print "hello from ", MCE->wid(), "\n"; } ); $mce->run(); threads->exit(0) if $INC{"threads.pm"}; With L 1.808 and later releases, L works just the same. The following compiles fine on UNIX and the Windows platform. # https://metacpan.org/pod/PAR::Packer # https://metacpan.org/pod/pp # # pp -o demo.exe demo.pl # ./demo.exe use strict; use warnings; use if $^O eq "MSWin32", "threads"; use if $^O eq "MSWin32", "threads::shared"; use Time::HiRes (); # include minimum dependencies for MCE::Hobo use Storable (); use IO::FDPass (); # optional: for MCE::Shared->condvar, handle, queue use Sereal (); # optional: faster serialization, may omit Storable use MCE::Hobo; # 1.808 or later on Windows use MCE::Shared; my $seq_a = MCE::Shared->sequence( 1, 30 ); sub task { my ( $id ) = @_; while ( defined ( my $num = $seq_a->next ) ) { print "$id: $num\n"; } } MCE::Hobo->new( \&task, $_ ) for 1 .. 2; MCE::Hobo->waitall; threads->exit(0) if $INC{"threads.pm"}; =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 = MainWindow->new( -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 = MainWindow->new( -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 = MainWindow->new( -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.901/lib/MCE/Queue.pm000644 000765 000024 00000152564 14735610752 015225 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## Hybrid (normal and priority) queues. ## ############################################################################### package MCE::Queue; use strict; use warnings; no warnings qw( threads recursion uninitialized ); our $VERSION = '1.901'; ## no critic (Subroutines::ProhibitExplicitReturnUndef) ## no critic (TestingAndDebugging::ProhibitNoStrict) use Scalar::Util qw( looks_like_number ); use MCE::Util qw( $LF ); use MCE::Mutex (); ############################################################################### ## ---------------------------------------------------------------------------- ## Import routine. ## ############################################################################### our ($HIGHEST,$LOWEST, $FIFO,$LIFO, $LILO,$FILO) = (1,0, 1,0, 1,0); my $_is_MSWin32 = ($^O eq 'MSWin32') ? 1 : 0; my ($_def, $_imported) = ({}); sub import { my ($_class, $_pkg) = (shift, caller); ## Process module arguments. my $_p = $_def->{$_pkg} = { AWAIT => 0, PORDER => $HIGHEST, TYPE => $FIFO, }; while (my $_argument = shift) { my $_arg = lc $_argument; $_p->{AWAIT } = shift, next if ( $_arg eq 'await' ); $_p->{PORDER} = shift, next if ( $_arg eq 'porder' ); $_p->{TYPE } = shift, next if ( $_arg eq 'type' ); _croak("Error: ($_argument) invalid module option"); } return if $_imported++; ## Define public methods to internal methods. no strict 'refs'; no warnings 'redefine'; if ($INC{'MCE.pm'} && MCE->wid == 0) { _mce_m_init(); } *{ 'MCE::Queue::await' } = \&_mce_m_await; *{ 'MCE::Queue::clear' } = \&_mce_m_clear; *{ 'MCE::Queue::end' } = \&_mce_m_end; *{ '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::dequeue_timed' } = \&_mce_m_dequeue_timed; *{ 'MCE::Queue::pending' } = \&_mce_m_pending; *{ 'MCE::Queue::insert' } = \&_mce_m_insert; *{ 'MCE::Queue::insertp' } = \&_mce_m_insertp; *{ 'MCE::Queue::peek' } = \&_mce_m_peek; *{ 'MCE::Queue::peekp' } = \&_mce_m_peekp; *{ 'MCE::Queue::peekh' } = \&_mce_m_peekh; *{ 'MCE::Queue::heap' } = \&_mce_m_heap; return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Define constants & variables. ## ############################################################################### use constant { OUTPUT_W_QUE => 'W~QUE', # Await from the queue OUTPUT_C_QUE => 'C~QUE', # Clear the queue OUTPUT_E_QUE => 'E~QUE', # End the queue OUTPUT_A_QUE => 'A~QUE', # Enqueue into queue (array) OUTPUT_A_QUP => 'A~QUP', # Enqueue into queue (array (p)) OUTPUT_D_QUE => 'D~QUE', # Dequeue from queue (blocking) OUTPUT_D_QUN => 'D~QUN', # Dequeue from queue (non-blocking) OUTPUT_D_QUT => 'D~QUT', # Dequeue from queue (timed) 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 _dsem _heap _id _init_pid _porder _type ## _ar_sock _aw_sock _asem _tsem my $_tid = $INC{'threads.pm'} ? threads->tid() : 0; my %_valid_fields_new = map { $_ => 1 } qw( await barrier fast gather porder queue type ); my $_all = {}; my $_qid = 0; sub CLONE { $_tid = threads->tid() if $INC{'threads.pm'}; } sub DESTROY { my ($_Q) = @_; my $_pid = $_tid ? $$ .'.'. $_tid : $$; delete $_all->{ $_Q->{_id} } if exists $_Q->{_id}; undef $_Q->{_datp}, undef $_Q->{_datq}, undef $_Q->{_heap}; if (exists $_Q->{_init_pid} && $_Q->{_init_pid} eq $_pid) { MCE::Util::_destroy_socks($_Q, qw(_aw_sock _ar_sock _qw_sock _qr_sock)); } 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} = (defined $_argv{await}) ? $_argv{await} : $_def->{$_pkg}{AWAIT} || 0; $_Q->{_porder} = (defined $_argv{porder}) ? $_argv{porder} : $_def->{$_pkg}{PORDER} || $HIGHEST; $_Q->{_type} = (defined $_argv{type}) ? $_argv{type} : $_def->{$_pkg}{TYPE} || $FIFO; ## ------------------------------------------------------------------------- if (exists $_argv{queue}) { _croak('Queue: (queue) is not an ARRAY reference') unless (ref $_argv{queue} eq 'ARRAY'); $_Q->{_datq} = $_argv{queue}; } else { $_Q->{_datq} = []; } if (exists $_argv{gather}) { _croak('Queue: (gather) is not a CODE reference') unless (ref $_argv{gather} eq 'CODE'); $_Q->{gather} = $_argv{gather}; } ## ------------------------------------------------------------------------- $_Q->{_qr_mutex} = MCE::Mutex->new(); $_Q->{_init_pid} = $_tid ? $$ .'.'. $_tid : $$; $_Q->{_id} = ++$_qid; $_all->{$_qid} = $_Q; $_Q->{_dsem} = 0; MCE::Util::_sock_pair($_Q, qw(_qr_sock _qw_sock), undef, 1); MCE::Util::_sock_pair($_Q, qw(_ar_sock _aw_sock), undef, 1) if $_Q->{_await}; return $_Q; } ############################################################################### ## ---------------------------------------------------------------------------- ## Private methods. ## ############################################################################### sub _croak { unless ($INC{'MCE.pm'}) { $\ = undef; require Carp; goto &Carp::croak; } else { goto &MCE::_croak; } } ## Add items to the tail of the queue with priority level. sub _enqueuep { my ($_Q, $_p) = (shift, shift); ## 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; } ## Return one item from the queue. sub _dequeue { my ($_Q) = @_; ## 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} }; } ## 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 ($INC{'MCE.pm'} && !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}; } ## 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, $_has_data, $_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>); _mce_m_clear($_all->{$_id}); print {$_DAU_R_SOCK} $LF; return; }, OUTPUT_E_QUE.$LF => sub { # End the queue $_DAU_R_SOCK = ${ $_DAU_R_SOCK_REF }; chomp($_id = <$_DAU_R_SOCK>); _mce_m_end($_all->{$_id}); 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 { $_Q->_mce_m_enqueue(@{ $_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}; $_Q->_mce_m_enqueuep($_p, @{ $_MCE->{thaw}($_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) { my $_pending = @{ $_Q->{_datq} }; if ($_pending < $_cnt && scalar @{ $_Q->{_heap} }) { for my $_h (@{ $_Q->{_heap} }) { $_pending += @{ $_Q->{_datp}->{$_h} }; } } $_cnt = $_pending if $_pending < $_cnt; for my $_i (1 .. $_cnt) { push @_items, $_Q->_dequeue() } } else { $_has_data = ( @{ $_Q->{_datq} } || @{ $_Q->{_heap} } ) ? 1 : 0; $_buf = $_Q->_dequeue(); } if ($_cnt) { $_buf = $_MCE->{freeze}(\@_items); print {$_DAU_R_SOCK} length($_buf).$LF, $_buf; } elsif ($_has_data) { $_buf = $_MCE->{freeze}([ $_buf ]); print {$_DAU_R_SOCK} length($_buf).$LF, $_buf; } elsif (exists $_Q->{_ended}) { print {$_DAU_R_SOCK} '-2'.$LF; } else { print {$_DAU_R_SOCK} '-1'.$LF; $_Q->{_dsem} += 1; } if ($_Q->{_await} && $_Q->{_asem} && $_Q->pending() <= $_Q->{_tsem}) { for my $_i (1 .. $_Q->{_asem}) { syswrite($_Q->{_aw_sock}, $LF); } $_Q->{_asem} = 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) { $_buf = $_MCE->{freeze}([ $_buf ]); print {$_DAU_R_SOCK} length($_buf).$LF, $_buf; } else { print {$_DAU_R_SOCK} '-1'.$LF; } } else { my @_items; my $_pending = @{ $_Q->{_datq} }; if ($_pending < $_cnt && scalar @{ $_Q->{_heap} }) { for my $_h (@{ $_Q->{_heap} }) { $_pending += @{ $_Q->{_datp}->{$_h} }; } } $_cnt = $_pending if $_pending < $_cnt; for my $_i (1 .. $_cnt) { push @_items, $_Q->_dequeue() } if ($_cnt) { 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 my $_i (1 .. $_Q->{_asem}) { syswrite($_Q->{_aw_sock}, $LF); } $_Q->{_asem} = 0; } return; }, OUTPUT_D_QUT.$LF => sub { # Dequeue from queue (Timed) $_DAU_R_SOCK = ${ $_DAU_R_SOCK_REF }; chomp($_id = <$_DAU_R_SOCK>); $_Q = $_all->{$_id}; $_Q->{_dsem} -= 1 if $_Q->{_dsem}; print {$_DAU_R_SOCK} $LF; 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}->_mce_m_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}; $_Q->_mce_m_insert($_i, @{ $_MCE->{thaw}($_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}; $_Q->_mce_m_insertp($_p, $_i, @{ $_MCE->{thaw}($_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->_mce_m_peek($_i); if (defined $_buf) { $_buf = $_MCE->{freeze}([ $_buf ]); print {$_DAU_R_SOCK} length($_buf).$LF, $_buf; } else { print {$_DAU_R_SOCK} '-1'.$LF; } 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->_mce_m_peekp($_p, $_i); if (defined $_buf) { $_buf = $_MCE->{freeze}([ $_buf ]); print {$_DAU_R_SOCK} length($_buf).$LF, $_buf; } else { print {$_DAU_R_SOCK} '-1'.$LF; } 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->_mce_m_peekh($_i); if (defined $_buf) { $_buf = $_MCE->{freeze}([ $_buf ]); print {$_DAU_R_SOCK} length($_buf).$LF, $_buf; } else { print {$_DAU_R_SOCK} '-1'.$LF; } 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->_mce_m_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 ); return; } } ############################################################################### ## ---------------------------------------------------------------------------- ## Methods for the manager process. ## ############################################################################### ## await ( pending_threshold ) sub _mce_m_await { # Handled by the manager process when called by MCE workers. return; } ## clear ( ) sub _mce_m_clear { my ($_Q) = @_; %{ $_Q->{_datp} } = (); @{ $_Q->{_datq} } = (); @{ $_Q->{_heap} } = (); return; } ## end ( ) sub _mce_m_end { my ($_Q) = @_; if (!exists $_Q->{_ended}) { for my $_i (1 .. $_Q->{_dsem}) { syswrite($_Q->{_qw_sock}, $LF) } $_Q->{_dsem} = 0, $_Q->{_ended} = undef; } return; } ## enqueue ( item [, item, ... ] ) sub _mce_m_enqueue { my $_Q = shift; return unless (scalar @_); if (exists $_Q->{_ended}) { warn "Queue: (enqueue) called on queue that has been 'end'ed\n"; return; } if ($_Q->{_dsem}) { for my $_i (1 .. scalar @_) { $_Q->{_dsem} -= 1, syswrite($_Q->{_qw_sock}, $LF); last unless $_Q->{_dsem}; } } ## Append item(s) into the queue. push @{ $_Q->{_datq} }, @_; return; } ## enqueuep ( priority, item [, item, ... ] ) 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 (exists $_Q->{_ended}) { warn "Queue: (enqueuep) called on queue that has been 'end'ed\n"; return; } if ($_Q->{_dsem}) { for my $_i (1 .. scalar @_) { $_Q->{_dsem} -= 1, syswrite($_Q->{_qw_sock}, $LF); last unless $_Q->{_dsem}; } } $_Q->_enqueuep($_p, @_); return; } ## dequeue ( ) ## dequeue ( count ) sub _mce_m_dequeue { my ($_Q, $_cnt) = @_; my (@_items, $_has_data, $_buf); 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 $_pending = @{ $_Q->{_datq} }; if ($_pending < $_cnt && scalar @{ $_Q->{_heap} }) { for my $_h (@{ $_Q->{_heap} }) { $_pending += @{ $_Q->{_datp}->{$_h} }; } } $_cnt = $_pending if $_pending < $_cnt; for my $_i (1 .. $_cnt) { push @_items, $_Q->_dequeue() } } else { $_has_data = ( @{ $_Q->{_datq} } || @{ $_Q->{_heap} } ) ? 1 : 0; $_buf = $_Q->_dequeue(); } return @_items if (scalar @_items); return $_buf if ($_has_data); return () if (exists $_Q->{_ended}); $_Q->{_dsem} += 1, MCE::Util::_sysread($_Q->{_qr_sock}, my($_next), 1); goto \&_mce_m_dequeue; } ## dequeue_nb ( ) ## dequeue_nb ( count ) sub _mce_m_dequeue_nb { my ($_Q, $_cnt) = @_; if (defined $_cnt && $_cnt ne '1') { _croak('Queue: (dequeue_nb count argument) is not valid') if (!looks_like_number($_cnt) || int($_cnt) != $_cnt || $_cnt < 1); my $_pending = @{ $_Q->{_datq} }; if ($_pending < $_cnt && scalar @{ $_Q->{_heap} }) { for my $_h (@{ $_Q->{_heap} }) { $_pending += @{ $_Q->{_datp}->{$_h} }; } } $_cnt = $_pending if $_pending < $_cnt; return map { $_Q->_dequeue() } 1 .. $_cnt; } my $_buf = $_Q->_dequeue(); return defined($_buf) ? $_buf : (); } ## dequeue_timed ( timeout ) ## dequeue_timed ( timeout, count ) sub _mce_m_dequeue_timed { my ($_Q, $_timeout, $_cnt) = @_; if (defined $_timeout) { _croak('Queue: (dequeue_timed timeout argument) is not valid') if (!looks_like_number($_timeout)); } if (defined $_cnt && $_cnt ne '1') { _croak('Queue: (dequeue_timed count argument) is not valid') if (!looks_like_number($_cnt) || int($_cnt) != $_cnt || $_cnt < 1); my $_pending = @{ $_Q->{_datq} }; if ($_pending < $_cnt && scalar @{ $_Q->{_heap} }) { for my $_h (@{ $_Q->{_heap} }) { $_pending += @{ $_Q->{_datp}->{$_h} }; } } $_cnt = $_pending if $_pending < $_cnt; return map { $_Q->_dequeue() } 1 .. $_cnt; } my $_buf = $_Q->_dequeue(); return defined($_buf) ? $_buf : (); } ## pending ( ) sub _mce_m_pending { my ($_Q) = @_; my $_pending = @{ $_Q->{_datq} }; if (scalar @{ $_Q->{_heap} }) { for my $_h (@{ $_Q->{_heap} }) { $_pending += @{ $_Q->{_datp}->{$_h} }; } } return (exists $_Q->{_ended}) ? $_pending ? $_pending : undef : $_pending; } ## insert ( index, item [, item, ... ] ) 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 (exists $_Q->{_ended}) { warn "Queue: (insert) called on queue that has been 'end'ed\n"; return; } if ($_Q->{_dsem}) { for my $_i (1 .. scalar @_) { $_Q->{_dsem} -= 1, syswrite($_Q->{_qw_sock}, $LF); last unless $_Q->{_dsem}; } } 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; } ## insertp ( priority, index, item [, item, ... ] ) 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 (exists $_Q->{_ended}) { warn "Queue: (insertp) called on queue that has been 'end'ed\n"; return; } if ($_Q->{_dsem}) { for my $_i (1 .. scalar @_) { $_Q->{_dsem} -= 1, syswrite($_Q->{_qw_sock}, $LF); last unless $_Q->{_dsem}; } } 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 ( index ) ## peek ( ) sub _mce_m_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]; } ## peekp ( priority, index ) ## peekp ( priority ) sub _mce_m_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]; } ## peekh ( index ) ## peekh ( ) sub _mce_m_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]; } ## heap ( ) sub _mce_m_heap { return @{ shift->{_heap} }; } ############################################################################### ## ---------------------------------------------------------------------------- ## Methods for the worker process. ## ############################################################################### { my ( $_MCE, $_DAT_LOCK, $_DAT_W_SOCK, $_DAU_W_SOCK, $_chn, $_lock_chn, $_dat_ex, $_dat_un, $_len, $_pending ); 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; }; 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]); <$_DAU_W_SOCK>; $_dat_un->() if $_lock_chn; }; my $_req3 = 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 defined($_[3]) ? () : undef; } read $_DAU_W_SOCK, my($_buf), $_len; $_dat_un->() if $_lock_chn; ($_[2] == 1) ? ($_MCE->{thaw}($_buf))->[0] : @{ $_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) { # inlined for performance $_dat_ex = sub { my $_pid = $_tid ? $$ .'.'. $_tid : $$; CORE::lock($_DAT_LOCK->{_t_lock}), MCE::Util::_sock_ready($_DAT_LOCK->{_r_sock}) if $_is_MSWin32; MCE::Util::_sysread($_DAT_LOCK->{_r_sock}, my($b), 1), $_DAT_LOCK->{ $_pid } = 1 unless $_DAT_LOCK->{ $_pid }; }; $_dat_un = sub { my $_pid = $_tid ? $$ .'.'. $_tid : $$; syswrite($_DAT_LOCK->{_w_sock}, '0'), $_DAT_LOCK->{ $_pid } = 0 if $_DAT_LOCK->{ $_pid }; }; } $_all = {}; no strict 'refs'; no warnings 'redefine'; *{ 'MCE::Queue::await' } = \&_mce_w_await; *{ 'MCE::Queue::clear' } = \&_mce_w_clear; *{ 'MCE::Queue::end' } = \&_mce_w_end; *{ '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::dequeue_timed' } = \&_mce_w_dequeue_timed; *{ '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); $_req2->(OUTPUT_W_QUE, $_Q->{_id}.$LF . $_t.$LF); MCE::Util::_sock_ready($_Q->{_ar_sock}) if $_is_MSWin32; MCE::Util::_sysread($_Q->{_ar_sock}, my($_next), 1); return; } sub _mce_w_clear { my ($_Q) = @_; return $_Q->_mce_m_clear() if (exists $_all->{ $_Q->{_id} }); $_req2->(OUTPUT_C_QUE, $_Q->{_id}.$LF); return; } sub _mce_w_end { my ($_Q) = @_; return $_Q->_mce_m_end() if (exists $_all->{ $_Q->{_id} }); $_req2->(OUTPUT_E_QUE, $_Q->{_id}.$LF); return; } ## ------------------------------------------------------------------------- sub _mce_w_enqueue { my $_Q = shift; return $_Q->_mce_m_enqueue(@_) if (exists $_all->{ $_Q->{_id} }); if (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 ($_Q, $_p) = (shift, shift); return $_Q->_mce_m_enqueuep($_p, @_) if (exists $_all->{ $_Q->{_id} }); _croak('Queue: (enqueuep priority) is not an integer') if (!looks_like_number($_p) || int($_p) != $_p); if (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; } { local $\ = undef if (defined $\); local $/ = $LF if ($/ ne $LF); $_dat_ex->() if $_lock_chn; print({$_DAT_W_SOCK} OUTPUT_D_QUE.$LF . $_chn.$LF), print({$_DAU_W_SOCK} $_Q->{_id}.$LF . $_cnt.$LF); chomp($_len = <$_DAU_W_SOCK>); read($_DAU_W_SOCK, $_buf, $_len) if ($_len >= 0); $_dat_un->() if $_lock_chn; } return ($_MCE->{thaw}($_buf))->[0] if ($_len > 0 && $_cnt == 1); return @{ $_MCE->{thaw}($_buf) } if ($_len > 0); return if ($_len == -2); MCE::Util::_sock_ready($_Q->{_qr_sock}) if $_is_MSWin32; MCE::Util::_sysread($_Q->{_qr_sock}, my($_next), 1); goto \&_mce_w_dequeue; } sub _mce_w_dequeue_nb { my ($_Q, $_cnt) = @_; return $_Q->_mce_m_dequeue_nb($_cnt) if (exists $_all->{ $_Q->{_id} }); if (defined $_cnt && $_cnt ne '1') { _croak('Queue: (dequeue_nb count argument) is not valid') if (!looks_like_number($_cnt) || int($_cnt) != $_cnt || $_cnt < 1); } else { $_cnt = 1; } $_req3->(OUTPUT_D_QUN, $_Q->{_id}.$LF . $_cnt.$LF, $_cnt, 1); } sub _mce_w_dequeue_timed { my ($_Q, $_timeout, $_cnt) = @_; my ($_buf, $_start); return $_Q->_mce_m_dequeue_timed($_timeout, $_cnt) if (exists $_all->{ $_Q->{_id} }); if (defined $_timeout) { _croak('Queue: (dequeue_timed count argument) is not valid') if (!looks_like_number($_timeout)); $_start = MCE::Util::_time(); } if (defined $_cnt && $_cnt ne '1') { _croak('Queue: (dequeue_timed count argument) is not valid') if (!looks_like_number($_cnt) || int($_cnt) != $_cnt || $_cnt < 1); } else { $_cnt = 1; } if (! $_timeout || $_timeout < 0.0) { return $_req3->(OUTPUT_D_QUN, $_Q->{_id}.$LF . $_cnt.$LF, $_cnt, 1); } { local $\ = undef if (defined $\); local $/ = $LF if ($/ ne $LF); $_dat_ex->() if $_lock_chn; print({$_DAT_W_SOCK} OUTPUT_D_QUE.$LF . $_chn.$LF), print({$_DAU_W_SOCK} $_Q->{_id}.$LF . $_cnt.$LF); chomp($_len = <$_DAU_W_SOCK>); read($_DAU_W_SOCK, $_buf, $_len) if ($_len >= 0); $_dat_un->() if $_lock_chn; } return ($_MCE->{thaw}($_buf))->[0] if ($_len > 0 && $_cnt == 1); return @{ $_MCE->{thaw}($_buf) } if ($_len > 0); return if ($_len == -2); $_Q->{_qr_mutex}->lock(); $_timeout = $_timeout - (MCE::Util::_time() - $_start) - 0.045; $_timeout = 0.0 if $_timeout < 0.045; CORE::vec(my $_r, CORE::fileno($_Q->{_qr_sock}), 1) = 1; if (CORE::select($_r, undef, undef, $_timeout) > 0) { MCE::Util::_sysread($_Q->{_qr_sock}, my($_next), 1); $_Q->{_qr_mutex}->unlock(); return $_req3->(OUTPUT_D_QUN, $_Q->{_id}.$LF . $_cnt.$LF, $_cnt, 1); } $_Q->{_qr_mutex}->unlock(); $_req2->(OUTPUT_D_QUT, $_Q->{_id}.$LF); MCE::Util::_sleep(0.045); # yield return (); } ## ------------------------------------------------------------------------- sub _mce_w_pending { my ($_Q) = @_; return $_Q->_mce_m_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; length($_pending) ? int($_pending) : undef; } sub _mce_w_insert { my ($_Q, $_i) = (shift, shift); return $_Q->_mce_m_insert($_i, @_) if (exists $_all->{ $_Q->{_id} }); _croak('Queue: (insert index) is not an integer') if (!looks_like_number($_i) || int($_i) != $_i); return unless (scalar @_); my $_tmp = $_MCE->{freeze}([ @_ ]); my $_buf = $_Q->{_id}.$LF . $_i.$LF . length($_tmp).$LF . $_tmp; $_req1->(OUTPUT_I_QUE, $_buf, ''); return; } sub _mce_w_insertp { my ($_Q, $_p, $_i) = (shift, shift, shift); return $_Q->_mce_m_insertp($_p, $_i, @_) if (exists $_all->{ $_Q->{_id} }); _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 @_); my $_tmp = $_MCE->{freeze}([ @_ ]); my $_buf = $_Q->{_id}.$LF . $_p.$LF . $_i.$LF . length($_tmp).$LF . $_tmp; $_req1->(OUTPUT_I_QUP, $_buf, ''); return; } ## ------------------------------------------------------------------------- sub _mce_w_peek { my $_Q = shift; my $_i = shift || 0; return $_Q->_mce_m_peek($_i, @_) if (exists $_all->{ $_Q->{_id} }); _croak('Queue: (peek index) is not an integer') if (!looks_like_number($_i) || int($_i) != $_i); $_req3->(OUTPUT_P_QUE, $_Q->{_id}.$LF . $_i.$LF, 1); } sub _mce_w_peekp { my ($_Q, $_p) = (shift, shift); my $_i = shift || 0; return $_Q->_mce_m_peekp($_p, $_i, @_) if (exists $_all->{ $_Q->{_id} }); _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); $_req3->(OUTPUT_P_QUP, $_Q->{_id}.$LF . $_p.$LF . $_i.$LF, 1); } sub _mce_w_peekh { my $_Q = shift; my $_i = shift || 0; return $_Q->_mce_m_peekh($_i, @_) if (exists $_all->{ $_Q->{_id} }); _croak('Queue: (peekh index) is not an integer') if (!looks_like_number($_i) || int($_i) != $_i); my $_ret = $_req3->(OUTPUT_P_QUH, $_Q->{_id}.$LF . $_i.$LF, 1); length($_ret) ? int($_ret) : undef; } sub _mce_w_heap { my ($_Q) = @_; return $_Q->_mce_m_heap() if (exists $_all->{ $_Q->{_id} }); $_req3->(OUTPUT_H_QUE, $_Q->{_id}.$LF, 0); } } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Queue - Hybrid (normal and priority) queues =head1 VERSION This document describes MCE::Queue version 1.901 =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. 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; 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 DEMONSTRATION MCE::Queue provides two run modes. (A) The C object is constructed before running MCE. The data resides under the manager process. Workers send and request data via IPC. (B) Workers might want to construct a queue for local access. In this mode, the data resides under the worker process and not available to other workers including the manager process. 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->end() 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. 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 taken from files_mce.pl and files_thr.pl on the web. https://github.com/marioroy/mce-examples/tree/master/other 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, and gather. Note: The barrier and fast options are silentently ignored (no-op) if specified; starting with 1.867. 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, barrier => 0 ); my $q8 = MCE::Queue->new( fast => 1 ); The C option, when enabled, allows workers to block (semaphore-like) until the number of items pending is equal to or less than a threshold value. The $q->await method is described below. Obsolete: On Unix platforms, C mode (enabled by default) prevents many workers from dequeuing simultaneously to lessen overhead for the OS kernel. Specify 0 to disable barrier mode and not allocate sockets. The barrier option has no effect if constructing the queue inside a thread or enabling C. Obsolete: The C option speeds up dequeues and is not enabled by default. It is beneficial for queues not calling (->dequeue_nb) and not altering the count value while running; e.g. ->dequeue($count). The C 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 C 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->end(); }, 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->end ( void ) Stops the queue from receiving more items. Any worker blocking on C will be unblocked automatically. Subsequent calls to C will behave like C. Current API available since MCE 1.818. $q->end(); MCE Models (e.g. MCE::Flow) may persist between runs. In that case, one might want to enqueue C's versus calling C. The number of C's depends on how many items workers dequeue at a time. $q->enqueue((undef) x ($N_workers * 1)); # $q->dequeue() 1 item $q->enqueue((undef) x ($N_workers * 2)); # $q->dequeue(2) 2 items $q->enqueue((undef) x ($N_workers * N)); # $q->dequeue(N) N items =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; $q->dequeue( 2 ); 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 whatever items there are on the queue. 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. # MCE::Queue 1.820 and prior releases while ( my @items = $q->dequeue(2) ) { last unless ( defined $items[0] ); ... } # MCE::Queue 1.821 and later while ( my @items = $q->dequeue(2) ) { ... } =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 returns C in the absence of data. $q->dequeue_nb; $q->dequeue_nb( 2 ); =head2 $q->dequeue_timed ( timeout [, $count ] ) Returns the requested number of items (default 1) from the queue. Like with dequeue, priority data will always dequeue first. This method is blocking until the timeout is reached and returns C in the absence of data. Current API available since MCE 1.886. $q->dequeue_timed( 300 ); # timeout after 5 minutes $q->dequeue_timed( 300, 2 ); The timeout may be specified as fractional seconds. If timeout is missing, undef, less than or equal to 0, or called by the manager process, then this call behaves like dequeue_nb. =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. Returns C if the queue has been ended, and there are no more items in the queue. $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.901/lib/MCE/Core/000755 000765 000024 00000000000 14735611252 014452 5ustar00mariostaff000000 000000 MCE-1.901/lib/MCE/Signal.pm000644 000765 000024 00000043555 14735610752 015355 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## Temporary directory creation/cleanup and signal handling. ## ############################################################################### package MCE::Signal; use strict; use warnings; no warnings qw( threads recursion uninitialized once ); our $VERSION = '1.901'; ## no critic (BuiltinFunctions::ProhibitStringyEval) our ($display_die_with_localtime, $display_warn_with_localtime); our ($main_proc_id, $prog_name, $tmp_dir); tie $tmp_dir, 'MCE::Signal::_tmpdir'; use Carp (); BEGIN { $main_proc_id = $$; $prog_name = $0; $prog_name =~ s{^.*[\\/]}{}g; $prog_name = 'perl' if ($prog_name eq '-e' || $prog_name eq '-'); return; } use base qw( Exporter ); use Time::HiRes (); our @EXPORT_OK = qw( $tmp_dir sys_cmd stop_and_exit ); our %EXPORT_TAGS = ( all => \@EXPORT_OK, tmp_dir => [ qw( $tmp_dir ) ] ); END { MCE::Signal->stop_and_exit($?) if ($$ == $main_proc_id && !$MCE::Signal::KILLED && !$MCE::Signal::STOPPED); } ############################################################################### ## ---------------------------------------------------------------------------- ## 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 $_use_dev_shm = 0; my $_no_kill9 = 0; my $_imported; sub import { my $_class = shift; return if $_imported++; my ($_no_setpgrp, $_no_sigmsg, $_setpgrp, @_export_args) = (0, 0, 0); while (my $_arg = shift) { $_setpgrp = _flag() and next if ($_arg eq '-setpgrp'); $_keep_tmp_dir = _flag() and next if ($_arg eq '-keep_tmp_dir'); $_use_dev_shm = _flag() and next if ($_arg eq '-use_dev_shm'); $_no_kill9 = _flag() and next if ($_arg eq '-no_kill9'); # deprecated options for backwards compatibility $_no_setpgrp = _flag() and next if ($_arg eq '-no_setpgrp'); $_no_sigmsg = _flag() and next if ($_arg eq '-no_sigmsg'); _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); ## Make tmp_dir if caller requested it. _make_tmpdir() if ($_use_dev_shm || grep /tmp_dir/, @_export_args); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Configure signal handling. ## ############################################################################### ## Set traps to catch signals. if ( !$_is_MSWin32 ) { $SIG{ABRT} = \&stop_and_exit; # UNIX SIG 6 $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'; } my $_safe_clean = 0; sub _make_tmpdir { my ($_count, $_tmp_base_dir) = (0); return $tmp_dir if (defined $tmp_dir && -d $tmp_dir && -w _); if ($ENV{TEMP} && -d $ENV{TEMP} && -w _) { if ($^O =~ /mswin|mingw|msys|cygwin/i) { $_tmp_base_dir = $ENV{TEMP} . '/Perl-MCE'; mkdir $_tmp_base_dir unless -d $_tmp_base_dir; } else { $_tmp_base_dir = $ENV{TEMP}; } } elsif (! -w '/tmp' && -e $ENV{TMPDIR} && -d $ENV{TMPDIR} && -w _) { $_tmp_base_dir = $ENV{TMPDIR}; } else { $_tmp_base_dir = ($_use_dev_shm && -d '/dev/shm' && -w _) ? '/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)) =~ /(.*)/; } $_safe_clean = 1; return $tmp_dir; } sub _remove_tmpdir { return if (!defined $tmp_dir || $tmp_dir eq '' || ! -d $tmp_dir); if ($_keep_tmp_dir == 1) { print {*STDERR} "$prog_name: saved tmp_dir = $tmp_dir\n"; } elsif ($_safe_clean) { if ($ENV{'TEMP'} && $^O =~ /mswin|mingw|msys|cygwin/i) { ## remove tainted'ness my ($_dir) = $ENV{'TEMP'} =~ /(.*)/; chdir $_dir if -d $_dir; } rmdir $tmp_dir; if (-d $tmp_dir) { local $@; local $SIG{__DIE__}; eval 'require File::Path; File::Path::rmtree($tmp_dir)'; } } $tmp_dir = undef; } ############################################################################### ## ---------------------------------------------------------------------------- ## Stops execution, removes temp directory and exits cleanly. ## ## Provides safe reentrant logic for parent and child processes. ## The $main_proc_id variable is defined above. ## ############################################################################### BEGIN { $MCE::Signal::IPC = 0; # 1 = defer signal_handling until completed IPC $MCE::Signal::SIG = ''; # signal received during IPC in MCE::Shared 1.863 } sub defer { $MCE::Signal::SIG = $_[0] if $_[0]; return; } my %_sig_name_lkup = map { $_ => 1 } qw( __DIE__ ABRT HUP INT PIPE QUIT TERM __WARN__ ); my $_count = 0; my $_handler_count = $INC{'threads/shared.pm'} ? threads::shared::share($_count) : \$_count; sub stop_and_exit { shift @_ if (defined $_[0] && $_[0] eq 'MCE::Signal'); return MCE::Signal::defer($_[0]) if $MCE::Signal::IPC; my ($_exit_status, $_is_sig, $_sig_name) = ($?, 0, $_[0] || 0); $SIG{__DIE__} = $SIG{__WARN__} = sub {}; if (exists $_sig_name_lkup{$_sig_name}) { $_exit_status = $MCE::Signal::KILLED = $_is_sig = 1; $_exit_status = 255, $_sig_name = 'TERM' if ($_sig_name eq '__DIE__'); $_exit_status = 0 if ($_sig_name eq 'PIPE'); $SIG{INT} = $SIG{$_sig_name} = sub {}; } else { $_exit_status = $_sig_name if ($_sig_name =~ /^\d+$/); $MCE::Signal::STOPPED = 1; } ## Main process. if ($$ == $main_proc_id) { if (++${ $_handler_count } == 1) { ## Kill process group if signaled. if ($_is_sig == 1) { ($_sig_name eq 'PIPE') ? CORE::kill('PIPE', $_is_MSWin32 ? -$$ : -getpgrp) : CORE::kill('INT' , $_is_MSWin32 ? -$$ : -getpgrp); if ($_sig_name eq 'PIPE') { for my $_i (1..2) { Time::HiRes::sleep(0.015); } } else { for my $_i (1..3) { Time::HiRes::sleep(0.060); } } } ## Remove temp directory. _remove_tmpdir() if defined($tmp_dir); ## Signal process group to die. if ($_is_sig == 1) { if ($_sig_name eq 'INT' && -t STDIN) { ## no critic print {*STDERR} "\n"; } if ($INC{'threads.pm'} && ($] lt '5.012000' || threads->tid())) { ($_no_kill9 == 1 || $_sig_name eq 'PIPE') ? CORE::kill('INT', $_is_MSWin32 ? -$$ : -getpgrp) : CORE::kill('KILL', -$$); } else { CORE::kill('INT', $_is_MSWin32 ? -$$ : -getpgrp); } } } } ## Child processes. elsif ($_is_sig) { ## Windows support, from nested workers. if ($_is_MSWin32) { _remove_tmpdir() if defined($tmp_dir); CORE::kill('KILL', $main_proc_id, -$$); } ## Real child processes. else { CORE::kill($_sig_name, $main_proc_id, -$$); CORE::kill('KILL', -$$, $$); } } ## Exit with status. CORE::exit($_exit_status); } ############################################################################### ## ---------------------------------------------------------------------------- ## 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; } ############################################################################### ## ---------------------------------------------------------------------------- ## 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]) { my $mesg = $_[0]; $mesg =~ s/, <__ANONIO__> line \d+//; if ($MCE::Signal::display_die_with_localtime) { my $_time_stamp = localtime; print {*STDERR} "## $_time_stamp: $prog_name: ERROR:\n", $mesg; } else { print {*STDERR} $mesg; } } 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] =~ /^Finished with active (?:child|hobo) processes/ || $_[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]) { my $mesg = $_[0]; $mesg =~ s/, <__ANONIO__> line \d+//; if ($MCE::Signal::display_warn_with_localtime) { my $_time_stamp = localtime; print {*STDERR} "## $_time_stamp: $prog_name: WARNING:\n", $mesg; } else { print {*STDERR} $mesg; } } return; } 1; ############################################################################### ## ---------------------------------------------------------------------------- ## TIE scalar package for making $MCE::Signal::tmp_dir on demand. ## ############################################################################### package MCE::Signal::_tmpdir; sub TIESCALAR { my $_class = shift; bless \do{ my $o = defined $_[0] ? shift : undef }, $_class; } sub STORE { ${ $_[0] } = $_[1]; $_safe_clean = 0 if ( length $_[1] < 9 ); $_safe_clean = 0 if ( $ENV{'TEMP'} && $ENV{'TEMP'} eq $_[1] ); $_safe_clean = 0 if ( $_[1] =~ m{[\\/](?:etc|bin|lib|sbin)} ); $_safe_clean = 0 if ( $_[1] =~ m{[\\/](?:temp|tmp)[\\/]?$}i ); $_[1]; } sub FETCH { if (!defined ${ $_[0] }) { my $_caller = caller(); if ($_caller ne 'MCE' && $_caller ne 'MCE::Signal') { if ($INC{'MCE.pm'} && MCE->wid() > 0) { ${ $_[0] } = MCE->tmp_dir(); } else { ${ $_[0] } = MCE::Signal::_make_tmpdir(); } } } ${ $_[0] }; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Signal - Temporary directory creation/cleanup and signal handling =head1 VERSION This document describes MCE::Signal version 1.901 =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{ ABRT, HUP, INT, PIPE, QUIT, and TERM } 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_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 DEFER SIGNAL =head2 defer ( $signal ) Returns immediately inside a signal handler if signaled during IPC. The signal is deferred momentarily and re-signaled automatically upon completing IPC. Currently, all IPC related methods in C and one method C in C set the flag C<$MCE::Signal::IPC> before initiating IPC. Current API available since 1.863. sub sig_handler { return MCE::Signal::defer($_[0]) if $MCE::Signal::IPC; ... } In a nutshell, C helps safeguard IPC from stalling between workers and the shared manager-process. The following is a demonstration for Unix platforms. Deferring the signal inside the C handler prevents the app from eventually failing while resizing the window. use strict; use warnings; use MCE::Hobo; use MCE::Shared; use Time::HiRes 'sleep'; my $count = MCE::Shared->scalar(0); my $winch = MCE::Shared->scalar(0); my $done = MCE::Shared->scalar(0); $SIG{WINCH} = sub { # defer signal if signaled during IPC return MCE::Signal::defer($_[0]) if $MCE::Signal::IPC; # mask signal handler local $SIG{$_[0]} = 'IGNORE'; printf "inside winch handler %d\n", $winch->incr; }; $SIG{INT} = sub { # defer signal if signaled during IPC return MCE::Signal::defer($_[0]) if $MCE::Signal::IPC; # set flag for workers to leave loop $done->set(1); }; sub task { while ( ! $done->get ) { $count->incr; sleep 0.03; }; } print "Resize the terminal window continuously.\n"; print "Press Ctrl-C to stop.\n"; MCE::Hobo->create('task') for 1..8; sleep 0.015 until $done->get; MCE::Hobo->wait_all; printf "\ncount incremented %d times\n\n", $count->get; =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Channel.pm000644 000765 000024 00000045333 14735610752 015504 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## Queue-like and two-way communication capability. ## ############################################################################### package MCE::Channel; use strict; use warnings; no warnings qw( uninitialized once ); our $VERSION = '1.901'; ## no critic (BuiltinFunctions::ProhibitStringyEval) ## no critic (TestingAndDebugging::ProhibitNoStrict) use if $^O eq 'MSWin32', 'threads'; use if $^O eq 'MSWin32', 'threads::shared'; use Carp (); $Carp::Internal{ (__PACKAGE__) }++; my ( $freeze, $thaw ); BEGIN { if ( $] ge '5.008008' && ! $INC{'PDL.pm'} ) { local $@; eval 'use Sereal::Encoder 3.015; use Sereal::Decoder 3.015;'; if ( ! $@ ) { my $encoder_ver = int( Sereal::Encoder->VERSION() ); my $decoder_ver = int( Sereal::Decoder->VERSION() ); if ( $encoder_ver - $decoder_ver == 0 ) { $freeze = \&Sereal::Encoder::encode_sereal; $thaw = \&Sereal::Decoder::decode_sereal; } } } if ( ! defined $freeze ) { require Storable; $freeze = \&Storable::freeze; $thaw = \&Storable::thaw; } } use MCE::Util (); my $tid = $INC{'threads.pm'} ? threads->tid() : 0; sub new { my ( $class, %argv ) = @_; my $impl = defined( $argv{impl} ) ? ucfirst( lc $argv{impl} ) : 'Mutex'; # Replace 'fast' with 'Fast' in the implementation value. $impl =~ s/fast/Fast/; $impl = 'Threads' if ( $impl eq 'Mutex' && $^O eq 'MSWin32' ); $impl = 'ThreadsFast' if ( $impl eq 'MutexFast' && $^O eq 'MSWin32' ); $impl = 'Mutex' if ( $impl eq 'Threads' && $^O eq 'cygwin' ); $impl = 'MutexFast' if ( $impl eq 'ThreadsFast' && $^O eq 'cygwin' ); eval "require MCE::Channel::$impl; 1;" || Carp::croak("Could not load Channel implementation '$impl': $@"); my $pkg = 'MCE::Channel::'.$impl; no strict 'refs'; $pkg->new(%argv); } sub CLONE { $tid = threads->tid if $INC{'threads.pm'}; } sub DESTROY { my ( $pid, $self ) = ( $tid ? $$ .'.'. $tid : $$, @_ ); if ( $self->{'init_pid'} && $self->{'init_pid'} eq $pid ) { MCE::Util::_destroy_socks($self, qw(c_sock c2_sock p_sock p2_sock)); delete($self->{c_mutex}), delete($self->{p_mutex}); } return; } sub impl { $_[0]->{'impl'} || 'Not defined'; } sub _get_freeze { $freeze; } sub _get_thaw { $thaw; } sub _ended { warn "WARNING: ($_[0]) called on a channel that has been 'end'ed\n"; return; } sub _read { my $bytes = MCE::Util::_sysread( $_[0], $_[1], my $len = $_[2] ); my $read = $bytes; while ( $bytes && $read != $len ) { $bytes = MCE::Util::_sysread( $_[0], $_[1], $len - $read, length($_[1]) ); $read += $bytes if $bytes; } return; } sub _pid { $tid ? $$ .'.'. $tid : $$; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Channel - Queue-like and two-way communication capability =head1 VERSION This document describes MCE::Channel version 1.901 =head1 SYNOPSIS use MCE::Channel; ######################## # Construction ######################## # A single producer and many consumers supporting processes and threads my $c1 = MCE::Channel->new( impl => 'Mutex' ); # default implementation my $c2 = MCE::Channel->new( impl => 'Threads' ); # threads::shared locking # Set the mp flag if two or more workers (many producers) will be calling # enqueue/send or recv2/recv2_nb on the left end of the channel my $c3 = MCE::Channel->new( impl => 'Mutex', mp => 1 ); my $c4 = MCE::Channel->new( impl => 'Threads', mp => 1 ); # Tuned for one producer and one consumer, no locking my $c5 = MCE::Channel->new( impl => 'Simple' ); ######################## # Queue-like behavior ######################## # Send data to consumers $c1->enqueue('item'); $c1->enqueue(qw/item1 item2 item3 itemN/); # Receive data my $item = $c1->dequeue(); # item my @items = $c1->dequeue(2); # (item1, item2) # Receive, non-blocking my $item = $c1->dequeue_nb(); # item my @items = $c1->dequeue_nb(2); # (item1, item2) # Signal that there is no more work to be sent $c1->end(); ######################## # Two-way communication ######################## # Producer(s) sending data $c3->send('message'); $c3->send(qw/arg1 arg2 arg3/); # Consumer(s) receiving data my $mesg = $c3->recv(); # message my @args = $c3->recv(); # (arg1, arg2, arg3) # Alternatively, non-blocking my $mesg = $c3->recv_nb(); # message my @args = $c3->recv_nb(); # (arg1, arg2, arg3) # A producer signaling no more work to be sent $c3->end(); # Consumers(s) sending data $c3->send2('message'); $c3->send2(qw/arg1 arg2 arg3/); # Producer(s) receiving data my $mesg = $c3->recv2(); # message my @args = $c3->recv2(); # (arg1, arg2, arg3) # Alternatively, non-blocking my $mesg = $c3->recv2_nb(); # message my @args = $c3->recv2_nb(); # (arg1, arg2, arg3) =head1 DESCRIPTION A MCE::Channel object is a container for sending and receiving data using socketpair handles. Serialization is provided by L if available. Defaults to L otherwise. Excluding the C implementation, both ends of the C support many workers concurrently (with mp => 1). =head2 new ( impl => STRING, mp => BOOLEAN ) This creates a new channel. Three implementations are provided C, C, and C indicating the locking mechanism to use C, C, and no locking respectively. $chnl = MCE::Channel->new(); # default: impl => 'Mutex', mp => 0 # default: impl => 'Threads' on Windows The C implementation supports processes and threads whereas the C implementation is suited for Windows and threads only. $chnl = MCE::Channel->new( impl => 'Mutex' ); # MCE::Mutex locking $chnl = MCE::Channel->new( impl => 'Threads' ); # threads::shared locking # on Windows, silently becomes impl => 'Threads' when specifying 'Mutex' Set the C (m)any (p)roducers option to a true value if there will be two or more workers calling C, , C, or C on the left end of the channel. This is important to not incur a race condition. $chnl = MCE::Channel->new( impl => 'Mutex', mp => 1 ); $chnl = MCE::Channel->new( impl => 'Threads', mp => 1 ); # on Windows, silently becomes impl => 'Threads' when specifying 'Mutex' The C implementation is optimized for one producer and one consumer max. It omits locking for maximum performance. This implementation is preferred for parent to child communication not shared by another worker. $chnl = MCE::Channel->new( impl => 'Simple' ); =head1 QUEUE-LIKE BEHAVIOR =head2 enqueue ( ITEM1 [, ITEM2, ... ] ) Appends a list of items onto the left end of the channel. This will block once the internal socket buffer becomes full (i.e. awaiting workers to dequeue on the other end). This prevents producer(s) from running faster than consumer(s). Object (de)serialization is handled automatically using L if available or defaults to L otherwise. $chnl->enqueue('item1'); $chnl->enqueue(qw/item2 item3 .../); $chnl->enqueue([ array_ref1 ]); $chnl->enqueue([ array_ref2 ], [ array_ref3 ], ...); $chnl->enqueue({ hash_ref1 }); $chnl->enqueue({ hash_ref2 }, { hash_ref3 }, ...); =head2 dequeue =head2 dequeue ( COUNT ) Removes the requested number of items (default 1) from the right end of the channel. If the channel contains fewer than the requested number of items, the method will block (i.e. until other producer(s) enqueue more items). $item = $chnl->dequeue(); # item1 @items = $chnl->dequeue(2); # ( item2, item3 ) =head2 dequeue_nb =head2 dequeue_nb ( COUNT ) Removes the requested number of items (default 1) from the right end of the channel. If the channel contains fewer than the requested number of items, the method will return what it was able to retrieve and return immediately. If the channel is empty, then returns C in list context or C in scalar context. $item = $chnl->dequeue_nb(); # array_ref1 @items = $chnl->dequeue_nb(2); # ( array_ref2, array_ref3 ) =head2 end This is called by a producer to signal that there is no more work to be sent. Once ended, no more items may be sent by the producer. Calling C by multiple producers is not supported. $chnl->end; =head1 TWO-WAY IPC - PRODUCER TO CONSUMER =head2 send ( ARG1 [, ARG2, ... ] ) Append data onto the left end of the channel. Unlike C, the values are kept together for the receiving consumer, similarly to calling a method. Object (de)serialization is handled automatically. $chnl->send('item'); $chnl->send([ list_ref ]); $chnl->send([ hash_ref ]); $chnl->send(qw/item1 item2 .../); $chnl->send($id, [ list_ref ]); $chnl->send($id, { hash_ref }); The fast channel implementations, introduced in MCE 1.877, support one item for C. If you want to pass multiple arguments, simply join the arguments into a string. That means the receiver will need to split the string. $chnl = MCE::Channel->new(impl => "SimpleFast"); $chnl->send(join(" ", qw/item1 item2 item3/); my ($item1, $item2, $item3) = split " ", $chnl->recv(); =head2 recv =head2 recv_nb Blocking and non-blocking fetch methods from the right end of the channel. For the latter and when the channel is empty, returns C in list context or C in scalar context. $item = $chnl->recv(); $array_ref = $chnl->recv(); $hash_ref = $chnl->recv(); ($item1, $item2) = $chnl->recv_nb(); ($id, $array_ref) = $chnl->recv_nb(); ($id, $hash_ref) = $chnl->recv_nb(); =head1 TWO-WAY IPC - CONSUMER TO PRODUCER =head2 send2 ( ARG1 [, ARG2, ... ] ) Append data onto the right end of the channel. Unlike C, the values are kept together for the receiving producer, similarly to calling a method. Object (de)serialization is handled automatically. $chnl->send2('item'); $chnl->send2([ list_ref ]); $chnl->send2([ hash_ref ]); $chnl->send2(qw/item1 item2 .../); $chnl->send2($id, [ list_ref ]); $chnl->send2($id, { hash_ref }); The fast channel implementations, introduced in MCE 1.877, support one item for C. If you want to pass multiple arguments, simply join the arguments into a string. Not to forget, the receiver must split the string as well. $chnl = MCE::Channel->new(impl => "MutexFast"); $chnl->send2(join(" ", qw/item1 item2 item3/); my ($item1, $item2, $item3) = split " ", $chnl->recv(); =head2 recv2 =head2 recv2_nb Blocking and non-blocking fetch methods from the left end of the channel. For the latter and when the channel is empty, returns C in list context or C in scalar context. $item = $chnl->recv2(); $array_ref = $chnl->recv2(); $hash_ref = $chnl->recv2(); ($item1, $item2) = $chnl->recv2_nb(); ($id, $array_ref) = $chnl->recv2_nb(); ($id, $hash_ref) = $chnl->recv2_nb(); =head1 DEMONSTRATIONS =head2 Example 1 - threads C was made to work efficiently with L. The reason comes from using L for locking versus L. use strict; use warnings; use threads; use MCE::Channel; my $queue = MCE::Channel->new( impl => 'Threads' ); my $num_consumers = 10; sub consumer { my $count = 0; # receive items while ( my ($item1, $item2) = $queue->dequeue(2) ) { $count += 2; } # send result $queue->send2( threads->tid => $count ); } threads->create('consumer') for 1 .. $num_consumers; ## producer $queue->enqueue($_, $_ * 2) for 1 .. 40000; $queue->end; my %results; my $total = 0; for ( 1 .. $num_consumers ) { my ($id, $count) = $queue->recv2; $results{$id} = $count; $total += $count; } $_->join for threads->list; print $results{$_}, "\n" for keys %results; print "$total total\n\n"; __END__ # output 8034 8008 8036 8058 7990 7948 8068 7966 7960 7932 80000 total =head2 Example 2 - MCE::Child The following is similarly threads-like for Perl lacking threads support. It spawns processes instead, thus requires the C channel implementation which is the default if omitted. use strict; use warnings; use MCE::Child; use MCE::Channel; my $queue = MCE::Channel->new( impl => 'Mutex' ); my $num_consumers = 10; sub consumer { my $count = 0; # receive items while ( my ($item1, $item2) = $queue->dequeue(2) ) { $count += 2; } # send result $queue->send2( MCE::Child->pid => $count ); } MCE::Child->create('consumer') for 1 .. $num_consumers; ## producer $queue->enqueue($_, $_ * 2) for 1 .. 40000; $queue->end; my %results; my $total = 0; for ( 1 .. $num_consumers ) { my ($id, $count) = $queue->recv2; $results{$id} = $count; $total += $count; } $_->join for MCE::Child->list; print $results{$_}, "\n" for keys %results; print "$total total\n\n"; =head2 Example 3 - Consumer requests item Like the previous example, but have the manager process await a notification from the consumer before inserting into the queue. This allows the producer to end the channel early (i.e. exit loop). use strict; use warnings; use MCE::Child; use MCE::Channel; my $queue = MCE::Channel->new( impl => 'Mutex' ); my $num_consumers = 10; sub consumer { # receive items my $count = 0; while () { # Notify the manager process to send items. This allows the # manager process to enqueue only when requested. The benefit # is being able to end the channel immediately. $queue->send2( MCE::Child->pid ); # channel is bi-directional my ($item1, $item2) = $queue->dequeue(2); last unless ( defined $item1 ); # channel ended $count += 2; } # result return ( MCE::Child->pid => $count ); } MCE::Child->create('consumer') for 1 .. $num_consumers; ## producer for my $num (1 .. 40000) { # Await worker notification before inserting (blocking). my $consumer_pid = $queue->recv2; $queue->enqueue($num, $num * 2); } $queue->end; my %results; my $total = 0; for my $child ( MCE::Child->list ) { my ($id, $count) = $child->join; $results{$id} = $count; $total += $count; } print $results{$_}, "\n" for keys %results; print "$total total\n\n"; =head2 Example 4 - Many producers Running with 2 or more producers requires setting the C option. Internally, this enables locking support for the left end of the channel. The C option applies to C and C channel implementations only. Here, using the MCE facility for gathering the final count. use strict; use warnings; use MCE::Flow; use MCE::Channel; my $queue = MCE::Channel->new( impl => 'Mutex', mp => 1 ); my $num_consumers = 10; sub consumer { # receive items my $count = 0; while ( my ( $item1, $item2 ) = $queue->dequeue(2) ) { $count += 2; } # send result MCE->gather( MCE->wid => $count ); } sub producer { $queue->enqueue($_, $_ * 2) for 1 .. 20000; } ## run 2 producers and many consumers MCE::Flow->init( max_workers => [ 2, $num_consumers ], task_name => [ 'producer', 'consumer' ], task_end => sub { my ($mce, $task_id, $task_name) = @_; if ( $task_name eq 'producer' ) { $queue->end; } } ); # consumers call gather above (i.e. send a key-value pair), # have MCE append to a hash my %results = mce_flow \&producer, \&consumer; MCE::Flow->finish; my $total = 0; for ( keys %results ) { $total += $results{$_}; print $results{$_}, "\n"; } print "$total total\n\n"; =head2 Example 5 - Many channels This demonstration configures a channel per consumer. Plus, a common channel for consumers to request the next input item. The C implementation is specified for the individual channels whereas locking may be necessary for the C<$ready> channel. However, consumers do not incur reading and what is written is very small (i.e. atomic write is guaranteed by the OS). Thus, am safely choosing the C implementation versus C. use strict; use warnings; use MCE::Flow; use MCE::Channel; my $prog_name = $0; $prog_name =~ s{^.*[\\/]}{}g; my $input_size = shift || 3000; unless ($input_size =~ /\A\d+\z/) { print {*STDERR} "usage: $prog_name [ size ]\n"; exit 1; } my $consumers = 4; my @chnls = map { MCE::Channel->new( impl => 'Simple' ) } 1 .. $consumers; my $ready = MCE::Channel->new( impl => 'Simple' ); sub producer { my $id = 0; # send the next input item upon request for ( 0 .. $input_size - 1 ) { my $chnl_num = $ready->recv2; $chnls[ $chnl_num ]->send( ++$id, $_ ); } # signal no more work $_->send( 0, undef ) for @chnls; } sub consumer { my $chnl_num = MCE->task_wid - 1; while () { # notify the producer ready for input $ready->send2( $chnl_num ); # retrieve input data my ( $id, $item ) = $chnls[ $chnl_num ]->recv; # leave loop if no more work last unless $id; # compute and send the result to the manager process # ordered output requires an id (must be 1st argument) MCE->gather( $id, [ $item, sqrt($item) ] ); } } # A custom 'ordered' output iterator for MCE's gather facility. # It returns a closure block, expecting an ID for 1st argument. sub output_iterator { my %tmp; my $order_id = 1; return sub { my ( $id, $result ) = @_; $tmp{ $id } = $result; while () { last unless exists $tmp{ $order_id }; $result = delete $tmp{ $order_id }; printf "n: %d sqrt(n): %f\n", $result->[0], $result->[1]; $order_id++; } }; } # Run one producer and many consumers. # Output to be sent orderly to STDOUT. MCE::Flow->init( gather => output_iterator(), max_workers => [ 1, $consumers ], ); MCE::Flow->run( \&producer, \&consumer ); MCE::Flow->finish; __END__ # Output n: 0 sqrt(n): 0.000000 n: 1 sqrt(n): 1.000000 n: 2 sqrt(n): 1.414214 n: 3 sqrt(n): 1.732051 n: 4 sqrt(n): 2.000000 n: 5 sqrt(n): 2.236068 n: 6 sqrt(n): 2.449490 n: 7 sqrt(n): 2.645751 n: 8 sqrt(n): 2.828427 n: 9 sqrt(n): 3.000000 ... =head1 SEE ALSO =over 3 =item * L =item * L =back =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =head1 COPYRIGHT AND LICENSE Copyright (C) 2019-2024 by Mario E. Roy MCE::Channel is released under the same license as Perl. See L for more information. =cut MCE-1.901/lib/MCE/Util.pm000644 000765 000024 00000033444 14735610752 015051 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## Utility functions. ## ############################################################################### package MCE::Util; use strict; use warnings; no warnings qw( threads recursion uninitialized numeric ); our $VERSION = '1.901'; ## no critic (BuiltinFunctions::ProhibitStringyEval) use IO::Handle (); use Socket qw( AF_UNIX SOL_SOCKET SO_SNDBUF SO_RCVBUF ); use Time::HiRes qw( sleep time ); use Errno (); use base qw( Exporter ); my ($_is_winenv, $_zero_bytes, %_sock_ready); BEGIN { $_is_winenv = ( $^O =~ /mswin|mingw|msys|cygwin/i ) ? 1 : 0; $_zero_bytes = pack('L', 0); } sub CLONE { %_sock_ready = (); } 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|android/ && do { my ( $count, $fh ); if ( open $fh, '<', '/proc/stat' ) { $count = grep { /^cpu\d/ } <$fh>; close $fh; } elsif ( open $fh, '<', '/proc/cpuinfo' ) { $count = grep { /^processor/ } <$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 = `lparstat -i 2>/dev/null | grep "^Online Virtual CPUs"`; if ( @output ) { $output[0] =~ /(\d+)\n$/; $ncpu = $1 if $1; } if ( !$ncpu ) { @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; }; /haiku/ && do { my @output = `sysinfo -cpu 2>/dev/null | grep "^CPU #"`; $ncpu = scalar @output 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 for pipes and sockets. ## ############################################################################### sub _destroy_pipes { my ($_obj, @_params) = @_; local ($!,$?); local $SIG{__DIE__}; 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] if (fileno $_obj->{$_p}[$_i]); undef $_obj->{$_p}[$_i]; } } else { close $_obj->{$_p} if (fileno $_obj->{$_p}); undef $_obj->{$_p}; } } return; } sub _destroy_socks { my ($_obj, @_params) = @_; local ($!,$?,$@); local $SIG{__DIE__}; 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) { # remove tainted'ness ($_i) = $_i =~ /(.*)/; pipe($_obj->{$_r_sock}[$_i], $_obj->{$_w_sock}[$_i]) or die "pipe: $!\n"; $_obj->{$_w_sock}[$_i]->autoflush(1); } else { pipe($_obj->{$_r_sock}, $_obj->{$_w_sock}) or die "pipe: $!\n"; $_obj->{$_w_sock}->autoflush(1); } return; } sub _sock_pair { my ($_obj, $_r_sock, $_w_sock, $_i, $_seq) = @_; my $_size = 16384; local ($!, $@); if (defined $_i) { # remove tainted'ness ($_i) = $_i =~ /(.*)/; if ($_seq && $^O eq 'linux' && eval q{ Socket::SOCK_SEQPACKET() }) { socketpair( $_obj->{$_r_sock}[$_i], $_obj->{$_w_sock}[$_i], AF_UNIX, Socket::SOCK_SEQPACKET(), 0 ) or do { socketpair( $_obj->{$_r_sock}[$_i], $_obj->{$_w_sock}[$_i], AF_UNIX, Socket::SOCK_STREAM(), 0 ) or die "socketpair: $!\n"; }; } else { socketpair( $_obj->{$_r_sock}[$_i], $_obj->{$_w_sock}[$_i], AF_UNIX, Socket::SOCK_STREAM(), 0 ) or die "socketpair: $!\n"; } if ($^O !~ /aix|linux|android/) { 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); } $_obj->{$_r_sock}[$_i]->autoflush(1); $_obj->{$_w_sock}[$_i]->autoflush(1); } else { if ($_seq && $^O eq 'linux' && eval q{ Socket::SOCK_SEQPACKET() }) { socketpair( $_obj->{$_r_sock}, $_obj->{$_w_sock}, AF_UNIX, Socket::SOCK_SEQPACKET(), 0 ) or do { socketpair( $_obj->{$_r_sock}, $_obj->{$_w_sock}, AF_UNIX, Socket::SOCK_STREAM(), 0 ) or die "socketpair: $!\n"; }; } else { socketpair( $_obj->{$_r_sock}, $_obj->{$_w_sock}, AF_UNIX, Socket::SOCK_STREAM(), 0 ) or die "socketpair: $!\n"; } if ($^O !~ /aix|linux|android/) { 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); } $_obj->{$_r_sock}->autoflush(1); $_obj->{$_w_sock}->autoflush(1); } return; } sub _sock_ready { my ($_socket, $_timeout) = @_; return '' if !defined $_timeout && $_sock_ready{"$_socket"} > 1; my ($_val_bytes, $_delay, $_start) = (pack('L', 0), 0, time); if (!defined $_timeout) { $_sock_ready{"$_socket"}++; } else { $_timeout = undef if $_timeout < 0; $_timeout += $_start if $_timeout; } while (1) { # MSWin32 FIONREAD - from winsock2.h macro ioctl($_socket, 0x4004667f, $_val_bytes); return '' if $_val_bytes ne $_zero_bytes; return 1 if $_timeout && time > $_timeout; # delay after a while to not consume a CPU core sleep(0.015), next if $_delay; $_delay = 1 if time - $_start > 0.030; } } sub _sock_ready_w { my ($_socket) = @_; return if $_sock_ready{"${_socket}_w"} > 1; my $_vec = ''; $_sock_ready{"${_socket}_w"}++; while (1) { vec($_vec, fileno($_socket), 1) = 1; return if select(undef, $_vec, undef, 0) > 0; sleep 0.045; } return; } sub _sysread { ( @_ == 3 ? CORE::sysread($_[0], $_[1], $_[2]) : CORE::sysread($_[0], $_[1], $_[2], $_[3]) ) or do { goto \&_sysread if ($! == Errno::EINTR()); }; } sub _sysread2 { my ($_bytes, $_delay, $_start); # called by MCE/Core/Manager.pm SYSREAD: $_bytes = ( @_ == 3 ? CORE::sysread($_[0], $_[1], $_[2]) : CORE::sysread($_[0], $_[1], $_[2], $_[3]) ) or do { unless ( defined $_bytes ) { goto SYSREAD if ($! == Errno::EINTR()); # non-blocking operation could not be completed if ( $! == Errno::EWOULDBLOCK() || $! == Errno::EAGAIN() ) { sleep(0.015), goto SYSREAD if $_delay; # delay after a while to not consume a CPU core $_start = time unless $_start; $_delay = 1 if time - $_start > 0.030; goto SYSREAD; } } }; return $_bytes; } sub _nonblocking { if ($^O eq 'MSWin32') { # MSWin32 FIONBIO - from winsock2.h macro my $nonblocking = $_[1] ? pack('L', 1) : pack('L', 0); ioctl($_[0], 0x8004667e, $nonblocking); } else { $_[0]->blocking( $_[1] ? 0 : 1 ); } return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Private methods, providing high-resolution time, for MCE->yield, ## MCE::Child->yield, and MCE::Hobo->yield. ## ############################################################################### ## Use monotonic clock if available. use constant CLOCK_MONOTONIC => eval { Time::HiRes::clock_gettime( Time::HiRes::CLOCK_MONOTONIC() ); 1; }; sub _sleep { my ( $seconds ) = @_; return if ( $seconds < 0 ); if ( $INC{'Coro/AnyEvent.pm'} ) { Coro::AnyEvent::sleep( $seconds ); } elsif ( &Time::HiRes::d_nanosleep ) { Time::HiRes::nanosleep( $seconds * 1e9 ); } elsif ( &Time::HiRes::d_usleep ) { Time::HiRes::usleep( $seconds * 1e6 ); } else { Time::HiRes::sleep( $seconds ); } return; } sub _time { return ( CLOCK_MONOTONIC ) ? Time::HiRes::clock_gettime( Time::HiRes::CLOCK_MONOTONIC() ) : Time::HiRes::time(); } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Util - Utility functions =head1 VERSION This document describes MCE::Util version 1.901 =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 may 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.901/lib/MCE/Subs.pm000644 000765 000024 00000025063 14735610752 015046 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## Exports functions mapped directly to MCE methods. ## ############################################################################### package MCE::Subs; use strict; use warnings; no warnings qw( threads recursion uninitialized ); our $VERSION = '1.901'; ## no critic (Subroutines::ProhibitSubroutinePrototypes) ## no critic (TestingAndDebugging::ProhibitNoStrict) use MCE; use MCE::Relay; ############################################################################### ## ---------------------------------------------------------------------------- ## Import routine. ## ############################################################################### sub import { 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_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_do (@) { return $MCE::MCE->do(@_); } 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_seed ( ) { return $MCE::MCE->seed(); } 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_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_do' } = \&mce_do; *{ $_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_seed' } = \&mce_seed; *{ $_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.901 =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_do =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_seed =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.901/lib/MCE/Stream.pm000644 000765 000024 00000076376 14735610752 015402 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## 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.901'; ## 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 $_tid = $INC{'threads.pm'} ? threads->tid() : 0; sub CLONE { $_tid = threads->tid() if $INC{'threads.pm'}; } ############################################################################### ## ---------------------------------------------------------------------------- ## 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', }; ## Import functions. if ($_pkg !~ /^MCE::/) { 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->{INIT_RELAY} = shift, next if ( $_arg eq 'init_relay' ); $_p->{USE_THREADS} = shift, next if ( $_arg eq 'use_threads' ); $_p->{DEFAULT_MODE} = shift, next if ( $_arg eq 'default_mode' ); shift, next if ( $_arg eq 'fast' ); # ignored ## Sereal 3.015+, if available, is used automatically by MCE 1.8+. 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::_parse_max_workers($_p->{MAX_WORKERS}); MCE::_validate_number($_p->{MAX_WORKERS}, 'MAX_WORKERS', $_tag); MCE::_validate_number($_p->{CHUNK_SIZE}, 'CHUNK_SIZE', $_tag) 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 MCE::Stream::_guard::DESTROY { my ($_pkg, $_id) = @{ $_[0] }; if (defined $_pkg && $_id eq "$$.$_tid") { @{ $_[0] } = (); MCE::Stream->finish($_pkg); } return; } sub init (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Stream'); my $_pkg = "$$.$_tid.".caller(); $_params->{$_pkg} = (ref $_[0] eq 'HASH') ? shift : { @_ }; _croak("$_tag: (HASH) not allowed as input by this MCE model") if ( ref $_params->{$_pkg}{input_data} eq 'HASH' ); @_ = (); defined wantarray ? bless([$_pkg, "$$.$_tid"], MCE::Stream::_guard::) : (); } 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 $_r = ref $_[$_i]; if ($_r eq '' || $_r =~ /^Math::/ || $_r eq 'HASH' || $_r eq 'ARRAY') { $_pos = $_i; if ($_r eq '' || $_r =~ /^Math::/) { $_begin = $_[$_pos], $_end = $_[$_pos + 1]; $_params->{$_pid}{sequence} = [ $_[$_pos], $_[$_pos + 1], $_[$_pos + 2], $_[$_pos + 3] ]; } elsif ($_r eq 'HASH') { $_begin = $_[$_pos]->{begin}, $_end = $_[$_pos]->{end}; $_params->{$_pid}{sequence} = $_[$_pos]; } elsif ($_r 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} = undef; 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 { last if (!exists $_[0]->{code} && !exists $_[0]->{mode}); 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 (@_ == 1 && $_r =~ /^(?:ARRAY|HASH|SCALAR|GLOB|FileHandle|IO::)/) { _croak("$_tag: (HASH) not allowed as input by this MCE model") if $_r eq 'HASH'; $_input_data = shift; } if (defined (my $_p = $_params->{$_pid})) { $_max_workers = MCE::_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 = do { my $_p = $_params->{$_pid} || {}; (defined $_p->{init_relay} || defined $_def->{$_pkg}{INIT_RELAY}) ? 1 : MCE::_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($_MCE->{$_pid}); if ($_init_mce || !exists $_queue->{$_pid}) { $_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() 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("$_tag: ($_) is not a valid constructor argument") unless (exists $MCE::_valid_fields_new{$_}); $_opts{$_} = $_p->{$_}; } } for my $_k (qw/ tmp_dir freeze thaw init_relay use_threads /) { $_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(); # destroy queue(s) if MCE::run requested workers to shutdown if (!$_MCE->{$_pid}{_spawned}) { $_->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; } 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.901 =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 { $_ * $_ }, \@list; ## Important; pass an array_ref for deeply input data my @c = mce_stream sub { $_->[1] *= 2; $_ }, [ [ 0, 1 ], [ 0, 2 ], ... ]; my @d = mce_stream sub { $_->[1] *= 2; $_ }, \@deeply_list; ## File path, glob ref, IO::All::{ File, Pipe, STDIO } obj, or scalar ref ## Workers read directly and not involve the manager process my @e = mce_stream_f sub { chomp; $_ }, "/path/to/file"; # efficient ## Involves the manager process, therefore slower my @f = mce_stream_f sub { chomp; $_ }, $file_handle; my @g = mce_stream_f sub { chomp; $_ }, $io; my @h = mce_stream_f sub { chomp; $_ }, \$scalar; ## Sequence of numbers (begin, end [, step, format]) my @i = mce_stream_s sub { $_ * $_ }, 1, 10000, 5; my @j = mce_stream_s sub { $_ * $_ }, [ 1, 10000, 5 ]; my @k = 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. The fast option is obsolete in 1.867 onwards; ignored if specified. 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 init_relay => 0, # Default undef; MCE 1.882+ use_threads => 0, # Default undef; MCE 1.882+ default_mode => 'grep', # Default 'map' ; From MCE 1.8 onwards, Sereal 3.015+ is loaded automatically if available. Specify C<< Sereal => 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 } =back 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). In scalar context (API available since 1.897), call Cfinish> automatically upon leaving the scope or program. use MCE::Stream; my $guard = 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 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 for providing input data. =over 3 =item MCE::Stream->run ( sub { code }, list ) =item mce_stream sub { code }, list =back Input data may be defined using a list or an array reference. Unlike MCE::Loop, Flow, and Step, specifying a hash reference as input data isn't allowed. ## Array or array_ref my @a = mce_stream sub { $_ * 2 }, 1..1000; my @b = mce_stream sub { $_ * 2 }, \@list; ## Important; pass an array_ref for deeply input data my @c = mce_stream sub { $_->[1] *= 2; $_ }, [ [ 0, 1 ], [ 0, 2 ], ... ]; my @d = mce_stream sub { $_->[1] *= 2; $_ }, \@deeply_list; ## Not supported my @z = mce_stream sub { ... }, \%hash; =over 3 =item MCE::Stream->run_file ( sub { code }, file ) =item mce_stream_f sub { code }, file =back The fastest of these is the /path/to/file. Workers communicate the next offset position among themselves with zero interaction by the manager process. C { File, Pipe, STDIO } is supported since MCE 1.845. my @c = mce_stream_f sub { chomp; $_ . "\r\n" }, "/path/to/file"; # faster my @d = mce_stream_f sub { chomp; $_ . "\r\n" }, $file_handle; my @e = mce_stream_f sub { chomp; $_ . "\r\n" }, $io; # IO::All my @f = mce_stream_f sub { chomp; $_ . "\r\n" }, \$scalar; =over 3 =item MCE::Stream->run_seq ( sub { code }, $beg, $end [, $step, $fmt ] ) =item mce_stream_s sub { code }, $beg, $end [, $step, $fmt ] =back Sequence may 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 }; =over 3 =item MCE::Stream->run ( { input_data => iterator }, sub { code } ) =item mce_stream { input_data => iterator }, sub { code } =back An iterator reference may be 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 section "SYNTAX for INPUT_DATA" at L. MCE::Stream->init( input_data => iterator ); my @a = mce_stream sub { $_ * 3 }, sub { $_ * 2 }; =head1 MANUAL SHUTDOWN =over 3 =item MCE::Stream->finish =item MCE::Stream::finish =back 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; =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Flow.pm000644 000765 000024 00000110616 14735610752 015040 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## Parallel flow model for building creative applications. ## ############################################################################### package MCE::Flow; use strict; use warnings; no warnings qw( threads recursion uninitialized ); our $VERSION = '1.901'; ## 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 $_tid = $INC{'threads.pm'} ? threads->tid() : 0; sub CLONE { $_tid = threads->tid() if $INC{'threads.pm'}; } ############################################################################### ## ---------------------------------------------------------------------------- ## 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. if ($_pkg !~ /^MCE::/) { 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' ); $_p->{INIT_RELAY} = shift, next if ( $_arg eq 'init_relay' ); $_p->{USE_THREADS} = shift, next if ( $_arg eq 'use_threads' ); ## Sereal 3.015+, if available, is used automatically by MCE 1.8+. 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::_parse_max_workers($_p->{MAX_WORKERS}); MCE::_validate_number($_p->{MAX_WORKERS}, 'MAX_WORKERS', $_tag); MCE::_validate_number($_p->{CHUNK_SIZE}, 'CHUNK_SIZE', $_tag) unless ($_p->{CHUNK_SIZE} eq 'auto'); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Init and finish routines. ## ############################################################################### sub MCE::Flow::_guard::DESTROY { my ($_pkg, $_id) = @{ $_[0] }; if (defined $_pkg && $_id eq "$$.$_tid") { @{ $_[0] } = (); MCE::Flow->finish($_pkg); } return; } sub init (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Flow'); my $_pkg = "$$.$_tid.".caller(); $_params->{$_pkg} = (ref $_[0] eq 'HASH') ? shift : { @_ }; @_ = (); defined wantarray ? bless([$_pkg, "$$.$_tid"], MCE::Flow::_guard::) : (); } 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 $_r = ref $_[$_i]; if ($_r eq '' || $_r =~ /^Math::/ || $_r eq 'HASH' || $_r eq 'ARRAY') { $_pos = $_i; if ($_r eq '' || $_r =~ /^Math::/) { $_begin = $_[$_pos], $_end = $_[$_pos + 1]; $_params->{$_pid}{sequence} = [ $_[$_pos], $_[$_pos + 1], $_[$_pos + 2], $_[$_pos + 3] ]; } elsif ($_r eq 'HASH') { $_begin = $_[$_pos]->{begin}, $_end = $_[$_pos]->{end}; $_params->{$_pid}{sequence} = $_[$_pos]; } elsif ($_r 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} = undef; 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 (@_ == 1 && $_r =~ /^(?:ARRAY|HASH|SCALAR|GLOB|FileHandle|IO::)/) { $_input_data = shift; } if (defined (my $_p = $_params->{$_pid})) { $_max_workers = MCE::_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::_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($_MCE->{$_pid}); 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("$_tag: ($_) is not a valid constructor argument") unless (exists $MCE::_valid_fields_new{$_}); $_opts{$_} = $_p->{$_}; } } for my $_k (qw/ tmp_dir freeze thaw init_relay use_threads /) { $_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; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Flow - Parallel flow model for building creative applications =head1 VERSION This document describes MCE::Flow version 1.901 =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($_) }, \@list; ## Important; pass an array_ref for deeply input data mce_flow sub { do_work($_) }, [ [ 0, 1 ], [ 0, 2 ], ... ]; mce_flow sub { do_work($_) }, \@deeply_list; ## File path, glob ref, IO::All::{ File, Pipe, STDIO } obj, or scalar ref ## Workers read directly and not involve the manager process mce_flow_f sub { chomp; do_work($_) }, "/path/to/file"; # efficient ## Involves the manager process, therefore slower mce_flow_f sub { chomp; do_work($_) }, $file_handle; mce_flow_f sub { chomp; do_work($_) }, $io; 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. ## Array or array_ref mce_flow sub { do_work($_) for (@{ $_ }) }, 1..10000; mce_flow sub { do_work($_) for (@{ $_ }) }, \@list; ## Important; pass an array_ref for deeply input data mce_flow sub { do_work($_) for (@{ $_ }) }, [ [ 0, 1 ], [ 0, 2 ], ... ]; mce_flow sub { do_work($_) for (@{ $_ }) }, \@deeply_list; ## Resembles code using the core MCE 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 init_relay => 0, # Default undef; MCE 1.882+ use_threads => 0, # Default undef; MCE 1.882+ ; From MCE 1.8 onwards, Sereal 3.015+ is loaded automatically if available. Specify C<< Sereal => 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 } =back The init function accepts a hash of MCE options. Unlike with MCE::Stream, both gather and bounds_only options may be specified (not shown below). In scalar context (API available since 1.897), call Cfinish> automatically upon leaving the scope or program. use MCE::Flow; my $guard = 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 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 for providing input data. =over 3 =item MCE::Flow->run ( sub { code }, list ) =item mce_flow sub { code }, list =back Input data may be defined using a list, an array ref, or a hash ref. Unlike MCE::Loop, Map, and Grep which take a block as C<{ ... }>, Flow takes a C or a code reference. The other difference is that the comma is needed after the block. # $_ contains the item when chunk_size => 1 mce_flow sub { do_work($_) }, 1..1000; mce_flow sub { do_work($_) }, \@list; # Important; pass an array_ref for deeply input data mce_flow sub { do_work($_) }, [ [ 0, 1 ], [ 0, 2 ], ... ]; mce_flow sub { do_work($_) }, \@deeply_list; # Chunking; any chunk_size => 1 or greater my %res = mce_flow sub { my ($mce, $chunk_ref, $chunk_id) = @_; my %ret; for my $item (@{ $chunk_ref }) { $ret{$item} = $item * 2; } MCE->gather(%ret); }, \@list; # Input hash; current API available since 1.828 my %res = mce_flow sub { my ($mce, $chunk_ref, $chunk_id) = @_; my %ret; for my $key (keys %{ $chunk_ref }) { $ret{$key} = $chunk_ref->{$key} * 2; } MCE->gather(%ret); }, \%hash; # Unlike MCE::Loop, MCE::Flow doesn't need input to run mce_flow { max_workers => 4 }, sub { MCE->say( MCE->wid ); }; # ... and can run multiple tasks mce_flow { max_workers => [ 1, 3 ], task_name => [ 'p', 'c' ] }, sub { # 1 producer MCE->say( "producer: ", MCE->wid ); }, sub { # 3 consumers MCE->say( "consumer: ", MCE->wid ); }; # Here, options are specified via init MCE::Flow->init( max_workers => [ 1, 3 ], task_name => [ 'p', 'c' ] ); mce_flow \&producer, \&consumers; =over 3 =item MCE::Flow->run_file ( sub { code }, file ) =item mce_flow_f sub { code }, file =back The fastest of these is the /path/to/file. Workers communicate the next offset position among themselves with zero interaction by the manager process. C { File, Pipe, STDIO } is supported since MCE 1.845. # $_ contains the line when chunk_size => 1 mce_flow_f sub { $_ }, "/path/to/file"; # faster mce_flow_f sub { $_ }, $file_handle; mce_flow_f sub { $_ }, $io; # IO::All mce_flow_f sub { $_ }, \$scalar; # chunking, any chunk_size => 1 or greater my %res = mce_flow_f sub { my ($mce, $chunk_ref, $chunk_id) = @_; my $buf = ''; for my $line (@{ $chunk_ref }) { $buf .= $line; } MCE->gather($chunk_id, $buf); }, "/path/to/file"; =over 3 =item MCE::Flow->run_seq ( sub { code }, $beg, $end [, $step, $fmt ] ) =item mce_flow_s sub { code }, $beg, $end [, $step, $fmt ] =back Sequence may 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"); # $_ contains the sequence number when chunk_size => 1 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 }; # chunking, any chunk_size => 1 or greater my %res = mce_flow_s sub { my ($mce, $chunk_ref, $chunk_id) = @_; my $buf = ''; for my $seq (@{ $chunk_ref }) { $buf .= "$seq\n"; } MCE->gather($chunk_id, $buf); }, [ $beg, $end ]; 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 ); # Typically, the input scalar $_ contains the sequence number # when chunk_size => 1, unless the bounds_only option is set # which is the case here. Thus, $_ points to $chunk_ref. mce_flow_s sub { my ($mce, $chunk_ref, $chunk_id) = @_; # $chunk_ref contains 2 items, not 1_250_000 # my ( $begin, $end ) = ( $_->[0], $_->[1] ); my $begin = $chunk_ref->[0]; my $end = $chunk_ref->[1]; # for my $seq ( $begin .. $end ) { # ... # } 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 =over 3 =item MCE::Flow->run ( { input_data => iterator }, sub { code } ) =item mce_flow { input_data => iterator }, sub { code } =back An iterator reference may be 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 section "SYNTAX for INPUT_DATA" at L. MCE::Flow->init( input_data => iterator ); mce_flow sub { $_ }; =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 @a1 = mce_flow sub { MCE->gather($_ * 2) }, 1..100; print "@a1\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 may 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 =back 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; =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Grep.pm000644 000765 000024 00000056135 14735610752 015033 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## 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.901'; ## 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 $_tid = $INC{'threads.pm'} ? threads->tid() : 0; sub CLONE { $_tid = threads->tid() if $INC{'threads.pm'}; } ############################################################################### ## ---------------------------------------------------------------------------- ## 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. if ($_pkg !~ /^MCE::/) { 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' ); $_p->{INIT_RELAY} = shift, next if ( $_arg eq 'init_relay' ); $_p->{USE_THREADS} = shift, next if ( $_arg eq 'use_threads' ); ## Sereal 3.015+, if available, is used automatically by MCE 1.8+. 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::_parse_max_workers($_p->{MAX_WORKERS}); MCE::_validate_number($_p->{MAX_WORKERS}, 'MAX_WORKERS', $_tag); MCE::_validate_number($_p->{CHUNK_SIZE}, 'CHUNK_SIZE', $_tag) 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 MCE::Grep::_guard::DESTROY { my ($_pkg, $_id) = @{ $_[0] }; if (defined $_pkg && $_id eq "$$.$_tid") { @{ $_[0] } = (); MCE::Grep->finish($_pkg); } return; } sub init (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Grep'); my $_pkg = "$$.$_tid.".caller(); $_params->{$_pkg} = (ref $_[0] eq 'HASH') ? shift : { @_ }; _croak("$_tag: (HASH) not allowed as input by this MCE model") if ( ref $_params->{$_pkg}{input_data} eq 'HASH' ); @_ = (); defined wantarray ? bless([$_pkg, "$$.$_tid"], MCE::Grep::_guard::) : (); } 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') { if (@{ $_[0] } > 3 && $_[0]->[3] =~ /\d$/) { $_begin = $_[0]->[0], $_end = $_[0]->[-1]; $_params->{$_pid}{sequence} = [ $_[0]->[0], $_[0]->[-1] ]; } else { $_begin = $_[0]->[0], $_end = $_[0]->[1]; $_params->{$_pid}{sequence} = $_[0]; } } elsif (ref $_[0] eq '' || ref($_[0]) =~ /^Math::/) { if (@_ > 3 && $_[3] =~ /\d$/) { $_begin = $_[0], $_end = $_[-1]; $_params->{$_pid}{sequence} = [ $_[0], $_[-1] ]; } else { $_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} = undef; @_ = (); 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 (@_ == 1 && $_r =~ /^(?:ARRAY|HASH|SCALAR|CODE|GLOB|FileHandle|IO::)/) { _croak("$_tag: (HASH) not allowed as input by this MCE model") if $_r eq 'HASH'; $_input_data = shift; } if (defined (my $_p = $_params->{$_pid})) { $_max_workers = MCE::_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 = do { my $_p = $_params->{$_pid} || {}; (defined $_p->{init_relay} || defined $_def->{$_pkg}{INIT_RELAY}) ? 1 : MCE::_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($_MCE->{$_pid}); 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("$_tag: ($_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 init_relay use_threads /) { $_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; } 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.901 =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 } \@list; ## Important; pass an array_ref for deeply input data my @c = mce_grep { $_->[1] % 2 == 0 } [ [ 0, 1 ], [ 0, 2 ], ... ]; my @d = mce_grep { $_->[1] % 2 == 0 } \@deeply_list; ## File path, glob ref, IO::All::{ File, Pipe, STDIO } obj, or scalar ref ## Workers read directly and not involve the manager process my @e = mce_grep_f { /pattern/ } "/path/to/file"; # efficient ## Involves the manager process, therefore slower my @f = mce_grep_f { /pattern/ } $file_handle; my @g = mce_grep_f { /pattern/ } $io; my @h = mce_grep_f { /pattern/ } \$scalar; ## Sequence of numbers (begin, end [, step, format]) my @i = mce_grep_s { %_ * 3 == 0 } 1, 10000, 5; my @j = mce_grep_s { %_ * 3 == 0 } [ 1, 10000, 5 ]; my @k = 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 init_relay => 0, # Default undef; MCE 1.882+ use_threads => 0, # Default undef; MCE 1.882+ ; From MCE 1.8 onwards, Sereal 3.015+ is loaded automatically if available. Specify C<< Sereal => 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 } =back The init function accepts a hash of MCE options. The gather option, if specified, is ignored due to being used internally by the module. In scalar context (API available since 1.897), call Cfinish> automatically upon leaving the scope or program. use MCE::Grep; my $guard = 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 =head1 API DOCUMENTATION =over 3 =item MCE::Grep->run ( sub { code }, list ) =item mce_grep { code } list =back Input data may be defined using a list or an array reference. Unlike MCE::Loop, Flow, and Step, specifying a hash reference as input data isn't allowed. ## Array or array_ref my @a = mce_grep { /[2357]/ } 1..1000; my @b = mce_grep { /[2357]/ } \@list; ## Important; pass an array_ref for deeply input data my @c = mce_grep { $_->[1] =~ /[2357]/ } [ [ 0, 1 ], [ 0, 2 ], ... ]; my @d = mce_grep { $_->[1] =~ /[2357]/ } \@deeply_list; ## Not supported my @z = mce_grep { ... } \%hash; =over 3 =item MCE::Grep->run_file ( sub { code }, file ) =item mce_grep_f { code } file =back The fastest of these is the /path/to/file. Workers communicate the next offset position among themselves with zero interaction by the manager process. C { File, Pipe, STDIO } is supported since MCE 1.845. my @c = mce_grep_f { /pattern/ } "/path/to/file"; # faster my @d = mce_grep_f { /pattern/ } $file_handle; my @e = mce_grep_f { /pattern/ } $io; # IO::All my @f = mce_grep_f { /pattern/ } \$scalar; =over 3 =item MCE::Grep->run_seq ( sub { code }, $beg, $end [, $step, $fmt ] ) =item mce_grep_s { code } $beg, $end [, $step, $fmt ] =back Sequence may 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 }; =over 3 =item MCE::Grep->run ( sub { code }, iterator ) =item mce_grep { code } iterator =back An iterator reference may be specified for input_data. Iterators are described under section "SYNTAX for INPUT_DATA" at L. my @a = mce_grep { $_ % 3 == 0 } make_iterator(10, 30, 2); =head1 MANUAL SHUTDOWN =over 3 =item MCE::Grep->finish =item MCE::Grep::finish =back 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; =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Core.pm000644 000765 000024 00000000566 14735610752 015023 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## Core MCE package, reserved for future development. ## ############################################################################### package MCE::Core; use strict; use warnings; our $VERSION = '1.901'; 1; MCE-1.901/lib/MCE/Relay.pm000644 000765 000024 00000073250 14735610752 015207 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## Extends Many-Core Engine with relay capabilities. ## ############################################################################### package MCE::Relay; use strict; use warnings; no warnings qw( threads recursion uninitialized numeric ); our $VERSION = '1.901'; ## no critic (Subroutines::ProhibitSubroutinePrototypes) use constant { OUTPUT_W_RLA => 'W~RLA', # Worker has relayed OUTPUT_R_NFY => 'R~NFY', # Relay notification }; ############################################################################### ## ---------------------------------------------------------------------------- ## Import routine. ## ############################################################################### my $LF = "\012"; Internals::SvREADONLY($LF, 1); my $_imported; sub import { return if ($_imported++); if ($INC{'MCE.pm'}) { _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 $_rla_nextid = 0 if ( ++$_rla_nextid == $_max_workers ); return; }, OUTPUT_R_NFY.$LF => sub { # Relay notification $_MCE->{_relayed}++; 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; $_MCE->{_relayed} = 0; if (ref $_MCE->{init_relay} eq '') { $_init_relay = $_MCE->{freeze}(\$_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}); delete $_MCE->{_relayed}; MCE::Util::_sock_ready($_RLA_R_SOCK, -1) if $^O eq 'MSWin32'; chomp($_len = <$_RLA_R_SOCK>); read $_RLA_R_SOCK, $_ret, $_len; if (chop $_ret) { $MCE::RLA->{$_caller} = $_MCE->{thaw}($_ret); } else { $MCE::RLA->{$_caller} = ${ $_MCE->{thaw}($_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 qw( threads recursion uninitialized redefine ); use Scalar::Util qw( weaken ); 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 defined') 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 $_; local $\ = undef if (defined $\); local $/ = $LF if ($/ ne $LF ); $_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; MCE::Util::_sock_ready($_rdr, -1) if $^O eq 'MSWin32'; chomp($_len = <$_rdr>); read $_rdr, $_, $_len; $_ref = chop $_; if ($_ref == 0) { ## scalar value $self->{_rla_data} = ${ $self->{thaw}($_) }; 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 defined') 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, $_cid, $_nxt, $_rdr, $_wtr); local $\ = undef if (defined $\); local $/ = $LF if ($/ ne $LF ); $_chn = $_cid = $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}) { my $_tmp; local $_ = delete $self->{_rla_data}; $_code->() if (ref $_code eq 'CODE'); if (ref $_ eq '') { ## scalar value $_tmp = $self->{freeze}(\$_) . '0'; } elsif (ref $_ eq 'HASH') { ## hash reference $_tmp = $self->{freeze}($_) . '1'; } elsif (ref $_ eq 'ARRAY') { ## array reference $_tmp = $self->{freeze}($_) . '2'; } print {$_wtr} length($_tmp) . $LF . $_tmp; print {$self->{_dat_w_sock}->[0]} OUTPUT_R_NFY.$LF . '0'.$LF; $self->{_relayed} = $_cid; } else { my ($_len, $_ref); local $_; print {$self->{_dat_w_sock}->[0]} OUTPUT_W_RLA.$LF . '0'.$LF; MCE::Util::_sock_ready($_rdr, -1) if $^O eq 'MSWin32'; chomp($_len = <$_rdr>); read $_rdr, $_, $_len; $_ref = chop $_; if ($_ref == 0) { ## scalar value my $_ret = ${ $self->{thaw}($_) }; local $_ = $_ret; $_code->() if (ref $_code eq 'CODE'); my $_tmp = $self->{freeze}(\$_) . '0'; print {$_wtr} length($_tmp) . $LF . $_tmp; print {$self->{_dat_w_sock}->[0]} OUTPUT_R_NFY.$LF . '0'.$LF; $self->{_relayed} = $_cid; 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; print {$self->{_dat_w_sock}->[0]} OUTPUT_R_NFY.$LF . '0'.$LF; $self->{_relayed} = $_cid; 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; print {$self->{_dat_w_sock}->[0]} OUTPUT_R_NFY.$LF . '0'.$LF; $self->{_relayed} = $_cid; 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.901 =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 { code } =item mce_relay { code } since 1.882 =item MCE->relay ( sub { code } ) =item $mce->relay ( sub { code } ) =back Relay is enabled by defining 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; my $pass = $wid % 3; # simulate work my $errs = $wid % 2; ## relay (include the trailing semicolon) 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 =over 3 =item MCE->relay_final ( void ) =item $mce->relay_final ( void ) =back 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 =over 3 =item MCE->relay_recv ( void ) =item $mce->relay_recv ( void ) =back 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 # https://benchmarksgame-team.pages.debian.net/benchmarksgame/ # # 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 ); =over 3 =item MCE->relay_lock ( void ) =item MCE->relay_unlock ( void ) =item $mce->relay_lock ( void ) =item $mce->relay_unlock ( void ) =back The C and C methods, added to MCE 1.807, are aliases for C and C respectively. Together, they allow one to perform an exclusive action prior to actual relaying of data. Relaying is driven by C or C when not processing input, as seen here. MCE->new( max_workers => 8, init_relay => 0, user_func => sub { MCE->relay_lock; MCE->say("wid: ", MCE->task_wid); MCE->relay_unlock( sub { $_ += 2; }); } )->run; MCE->say("sum: ", MCE->relay_final); __END__ wid: 1 wid: 2 wid: 3 wid: 4 wid: 5 wid: 6 wid: 7 wid: 8 sum: 16 Described above, C takes a code block and combines C and C into a single call. To make this more interesting, I define C to a hash containing two key-value pairs. MCE->new( max_workers => 8, init_relay => { count => 0, total => 0 }, user_func => sub { MCE->relay_lock; MCE->say("wid: ", MCE->task_wid); MCE->relay_unlock( sub { $_->{count} += 1; $_->{total} += 2; }); } )->run; my %results = MCE->relay_final; MCE->say("count: ", $results{count}); MCE->say("total: ", $results{total}); __END__ wid: 1 wid: 2 wid: 3 wid: 4 wid: 5 wid: 6 wid: 7 wid: 8 count: 8 total: 16 Below, C is taken from the C MCE example. Incrementing the count is done only when the C<-n> switch is passed to the script. Otherwise, output is displaced orderly and not necessary to update the C<$_> value if exclusive locking is all you need. 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 # https://benchmarksgame-team.pages.debian.net/benchmarksgame/ # # 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 ); =head1 GATHER AND RELAY DEMONSTRATIONS I received a request from John Martel to process a large flat file and expand each record to many records based on splitting out items in field 4 delimited by semicolons. Each row in the output is given a unique ID starting with one while preserving output order. =over 3 =item Input File, possibly larger than 500 GiB in size foo|field2|field3|item1;item2;item3;item4;itemN|field5|field6|field7 bar|field2|field3|item1;item2;item3;item4;itemN|field5|field6|field7 baz|field2|field3|item1;item2;item3;item4;itemN|field5|field6|field7 ... =item Output File 000000000000001|item1|foo|field2|field3|field5|field6|field7 000000000000002|item2|foo|field2|field3|field5|field6|field7 000000000000003|item3|foo|field2|field3|field5|field6|field7 000000000000004|item4|foo|field2|field3|field5|field6|field7 000000000000005|itemN|foo|field2|field3|field5|field6|field7 000000000000006|item1|bar|field2|field3|field5|field6|field7 000000000000007|item2|bar|field2|field3|field5|field6|field7 000000000000008|item3|bar|field2|field3|field5|field6|field7 000000000000009|item4|bar|field2|field3|field5|field6|field7 000000000000010|itemN|bar|field2|field3|field5|field6|field7 000000000000011|item1|baz|field2|field3|field5|field6|field7 000000000000012|item2|baz|field2|field3|field5|field6|field7 000000000000013|item3|baz|field2|field3|field5|field6|field7 000000000000014|item4|baz|field2|field3|field5|field6|field7 000000000000015|itemN|baz|field2|field3|field5|field6|field7 ... =item Example One =back This example configures a custom function for preserving output order. Unfortunately, the sprintf function alone involves extra CPU time causing the manager process to fall behind. Thus, workers may idle while waiting for the manager process to respond to the gather request. use strict; use warnings; use MCE::Loop; my $infile = shift or die "Usage: $0 infile\n"; my $newfile = 'output.dat'; open my $fh_out, '>', $newfile or die "open error $newfile: $!\n"; sub preserve_order { my ($fh) = @_; my ($order_id, $start_idx, $idx, %tmp) = (1, 1); return sub { my ($chunk_id, $aref) = @_; $tmp{ $chunk_id } = $aref; while ( my $aref = delete $tmp{ $order_id } ) { foreach my $line ( @{ $aref } ) { $idx = sprintf "%015d", $start_idx++; print $fh $idx, $line; } $order_id++; } } } MCE::Loop->init( chunk_size => 'auto', max_workers => 3, gather => preserve_order($fh_out) ); mce_loop_f { my ($mce, $chunk_ref, $chunk_id) = @_; my @buf; foreach my $line (@{ $chunk_ref }) { $line =~ s/\r//g; chomp $line; my ($f1,$f2,$f3,$items,$f5,$f6,$f7) = split /\|/, $line; my @items_array = split /;/, $items; foreach my $item (@items_array) { push @buf, "|$item|$f1|$f2|$f3|$f5|$f6|$f7\n"; } } MCE->gather($chunk_id, \@buf); } $infile; MCE::Loop->finish(); close $fh_out; =over 3 =item Example Two =back In this example, workers obtain the current ID value and increment/relay for the next worker, ordered by chunk ID behind the scene. Workers call sprintf in parallel, allowing the manager process (out_iter_fh) to accommodate up to 32 workers and not fall behind. Relay accounts for the worker handling the next chunk_id value. Therefore, do not call relay more than once per chunk. Doing so will cause IPC to stall. use strict; use warnings; use MCE::Loop; use MCE::Candy; my $infile = shift or die "Usage: $0 infile\n"; my $newfile = 'output.dat'; open my $fh_out, '>', $newfile or die "open error $newfile: $!\n"; MCE::Loop->init( chunk_size => 'auto', max_workers => 8, gather => MCE::Candy::out_iter_fh($fh_out), init_relay => 1 ); mce_loop_f { my ($mce, $chunk_ref, $chunk_id) = @_; my @lines; foreach my $line (@{ $chunk_ref }) { $line =~ s/\r//g; chomp $line; my ($f1,$f2,$f3,$items,$f5,$f6,$f7) = split /\|/, $line; my @items_array = split /;/, $items; foreach my $item (@items_array) { push @lines, "$item|$f1|$f2|$f3|$f5|$f6|$f7\n"; } } my $idx = MCE::relay { $_ += scalar @lines }; my $buf = ''; foreach my $line ( @lines ) { $buf .= sprintf "%015d|%s", $idx++, $line } MCE->gather($chunk_id, $buf); } $infile; MCE::Loop->finish(); close $fh_out; =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Channel/000755 000765 000024 00000000000 14735611252 015132 5ustar00mariostaff000000 000000 MCE-1.901/lib/MCE/Step.pm000644 000765 000024 00000133556 14735610752 015054 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## Parallel step model for building creative steps. ## ############################################################################### package MCE::Step; use strict; use warnings; no warnings qw( threads recursion uninitialized ); our $VERSION = '1.901'; ## 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 $_tid = $INC{'threads.pm'} ? threads->tid() : 0; sub CLONE { $_tid = threads->tid() if $INC{'threads.pm'}; } ############################################################################### ## ---------------------------------------------------------------------------- ## 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', }; ## Import functions. if ($_pkg !~ /^MCE::/) { 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->{INIT_RELAY} = shift, next if ( $_arg eq 'init_relay' ); $_p->{USE_THREADS} = shift, next if ( $_arg eq 'use_threads' ); shift, next if ( $_arg eq 'fast' ); # ignored ## Sereal 3.015+, if available, is used automatically by MCE 1.8+. 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::_parse_max_workers($_p->{MAX_WORKERS}); MCE::_validate_number($_p->{MAX_WORKERS}, 'MAX_WORKERS', $_tag); MCE::_validate_number($_p->{CHUNK_SIZE}, 'CHUNK_SIZE', $_tag) 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}) { $_queue->{$_pid}[$_task_id]->enqueue($self->freeze([ @_ ])); } 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 { $self->freeze([ $_ ]) } @_; $_queue->{$_pid}[$_task_id]->enqueue(@_items); } else { $_queue->{$_pid}[$_task_id]->enqueue($self->freeze([ @_ ])); } } 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 { $self->freeze([ $_ ]) } @_; $_queue->{$_pid}[$_task_id]->enqueuep($_p, @_items); } else { $_queue->{$_pid}[$_task_id]->enqueuep($_p, $self->freeze([ @_ ])); } } 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 MCE::Step::_guard::DESTROY { my ($_pkg, $_id) = @{ $_[0] }; if (defined $_pkg && $_id eq "$$.$_tid") { @{ $_[0] } = (); MCE::Step->finish($_pkg); } return; } sub init (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Step'); my $_pkg = "$$.$_tid.".caller(); $_params->{$_pkg} = (ref $_[0] eq 'HASH') ? shift : { @_ }; @_ = (); defined wantarray ? bless([$_pkg, "$$.$_tid"], MCE::Step::_guard::) : (); } 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 $_r = ref $_[$_i]; if ($_r eq '' || $_r =~ /^Math::/ || $_r eq 'HASH' || $_r eq 'ARRAY') { $_pos = $_i; if ($_r eq '' || $_r =~ /^Math::/) { $_begin = $_[$_pos], $_end = $_[$_pos + 1]; $_params->{$_pid}{sequence} = [ $_[$_pos], $_[$_pos + 1], $_[$_pos + 2], $_[$_pos + 3] ]; } elsif ($_r eq 'HASH') { $_begin = $_[$_pos]->{begin}, $_end = $_[$_pos]->{end}; $_params->{$_pid}{sequence} = $_[$_pos]; } elsif ($_r 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} = undef; 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 (@_ == 1 && $_r =~ /^(?:ARRAY|HASH|SCALAR|GLOB|FileHandle|IO::)/) { $_input_data = shift; } if (defined (my $_p = $_params->{$_pid})) { $_max_workers = MCE::_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::_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($_MCE->{$_pid}); if ($_init_mce || !exists $_queue->{$_pid}) { $_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(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("$_tag: ($_) is not a valid constructor argument") unless (exists $MCE::_valid_fields_new{$_}); $_opts{$_} = $_p->{$_}; } } for my $_k (qw/ tmp_dir freeze thaw init_relay use_threads /) { $_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(); # destroy queue(s) if MCE::run requested workers to shutdown if (!$_MCE->{$_pid}{_spawned}) { $_->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())) { my $_args = $_mce->thaw($_); $_ = $_args->[0]; $_code->($_mce, @{ $_args }); } _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; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Step - Parallel step model for building creative steps =head1 VERSION This document describes MCE::Step version 1.901 =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($_) }, \@list; ## Important; pass an array_ref for deeply input data mce_step sub { do_work($_) }, [ [ 0, 1 ], [ 0, 2 ], ... ]; mce_step sub { do_work($_) }, \@deeply_list; ## File path, glob ref, IO::All::{ File, Pipe, STDIO } obj, or scalar ref ## Workers read directly and not involve the manager process mce_step_f sub { chomp; do_work($_) }, "/path/to/file"; # efficient ## Involves the manager process, therefore slower mce_step_f sub { chomp; do_work($_) }, $file_handle; mce_step_f sub { chomp; do_work($_) }, $io; 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. ## Array or array_ref mce_step sub { do_work($_) for (@{ $_ }) }, 1..10000; mce_step sub { do_work($_) for (@{ $_ }) }, \@list; ## Important; pass an array_ref for deeply input data mce_step sub { do_work($_) for (@{ $_ }) }, [ [ 0, 1 ], [ 0, 2 ], ... ]; mce_step sub { do_work($_) for (@{ $_ }) }, \@deeply_list; ## Resembles code using the core MCE 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. The fast option is obsolete in 1.867 onwards; ignored if specified. 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 init_relay => 0, # Default undef; MCE 1.882+ use_threads => 0, # Default undef; MCE 1.882+ ; From MCE 1.8 onwards, Sereal 3.015+ is loaded automatically if available. Specify C<< Sereal => 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 } =back The init function accepts a hash of MCE options. Unlike with MCE::Stream, both gather and bounds_only options may be specified (not shown below). In scalar context (API available since 1.897), call Cfinish> automatically upon leaving the scope or program. use MCE::Step; my $guard = 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 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 for providing input data. =over 3 =item MCE::Step->run ( sub { code }, list ) =item mce_step sub { code }, list =back Input data may be defined using a list, an array ref, or a hash ref. Unlike MCE::Loop, Map, and Grep which take a block as C<{ ... }>, Step takes a C or a code reference. The other difference is that the comma is needed after the block. # $_ contains the item when chunk_size => 1 mce_step sub { do_work($_) }, 1..1000; mce_step sub { do_work($_) }, \@list; # Important; pass an array_ref for deeply input data mce_step sub { do_work($_) }, [ [ 0, 1 ], [ 0, 2 ], ... ]; mce_step sub { do_work($_) }, \@deeply_list; # Chunking; any chunk_size => 1 or greater my %res = mce_step sub { my ($mce, $chunk_ref, $chunk_id) = @_; my %ret; for my $item (@{ $chunk_ref }) { $ret{$item} = $item * 2; } MCE->gather(%ret); }, \@list; # Input hash; current API available since 1.828 my %res = mce_step sub { my ($mce, $chunk_ref, $chunk_id) = @_; my %ret; for my $key (keys %{ $chunk_ref }) { $ret{$key} = $chunk_ref->{$key} * 2; } MCE->gather(%ret); }, \%hash; # Unlike MCE::Loop, MCE::Step doesn't need input to run mce_step { max_workers => 4 }, sub { MCE->say( MCE->wid ); }; # ... and can run multiple tasks mce_step { max_workers => [ 1, 3 ], task_name => [ 'p', 'c' ] }, sub { # 1 producer MCE->say( "producer: ", MCE->wid ); }, sub { # 3 consumers MCE->say( "consumer: ", MCE->wid ); }; # Here, options are specified via init MCE::Step->init( max_workers => [ 1, 3 ], task_name => [ 'p', 'c' ] ); mce_step \&producer, \&consumers; =over 3 =item MCE::Step->run_file ( sub { code }, file ) =item mce_step_f sub { code }, file =back The fastest of these is the /path/to/file. Workers communicate the next offset position among themselves with zero interaction by the manager process. C { File, Pipe, STDIO } is supported since MCE 1.845. # $_ contains the line when chunk_size => 1 mce_step_f sub { $_ }, "/path/to/file"; # faster mce_step_f sub { $_ }, $file_handle; mce_step_f sub { $_ }, $io; # IO::All mce_step_f sub { $_ }, \$scalar; # chunking, any chunk_size => 1 or greater my %res = mce_step_f sub { my ($mce, $chunk_ref, $chunk_id) = @_; my $buf = ''; for my $line (@{ $chunk_ref }) { $buf .= $line; } MCE->gather($chunk_id, $buf); }, "/path/to/file"; =over 3 =item MCE::Step->run_seq ( sub { code }, $beg, $end [, $step, $fmt ] ) =item mce_step_s sub { code }, $beg, $end [, $step, $fmt ] =back Sequence may 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"); # $_ contains the sequence number when chunk_size => 1 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 }; # chunking, any chunk_size => 1 or greater my %res = mce_step_s sub { my ($mce, $chunk_ref, $chunk_id) = @_; my $buf = ''; for my $seq (@{ $chunk_ref }) { $buf .= "$seq\n"; } MCE->gather($chunk_id, $buf); }, [ $beg, $end ]; 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 ); # Typically, the input scalar $_ contains the sequence number # when chunk_size => 1, unless the bounds_only option is set # which is the case here. Thus, $_ points to $chunk_ref. mce_step_s sub { my ($mce, $chunk_ref, $chunk_id) = @_; # $chunk_ref contains 2 items, not 1_250_000 # my ( $begin, $end ) = ( $_->[0], $_->[1] ); my $begin = $chunk_ref->[0]; my $end = $chunk_ref->[1]; # for my $seq ( $begin .. $end ) { # ... # } 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 =over 3 =item MCE::Step->run ( { input_data => iterator }, sub { code } ) =item mce_step { input_data => iterator }, sub { code } =back An iterator reference may be 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 section "SYNTAX for INPUT_DATA" at L. MCE::Step->init( input_data => iterator ); mce_step sub { $_ }; =head1 QUEUE-LIKE FEATURES =over 3 =item MCE->step ( item ) =item MCE->step ( arg1, arg2, argN ) =back 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 =over 3 =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 ] ) =back 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 =over 3 =item MCE->await ( task_name, pending_threshold ) =back 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 =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 may 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 =back 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; =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Core.pod000644 000765 000024 00000215471 14735610752 015174 0ustar00mariostaff000000 000000 =head1 NAME MCE::Core - Documentation describing the core MCE API =head1 VERSION This document describes MCE::Core version 1.901 =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. # MCE sets an upper-limit of 8 for 'auto'. MCE 1.521+. # 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 # Specify a percentage. MCE 1.875+. # max_workers => '25%', # 4 on HW with 16 lcores # max_workers => '50%', # 8 on HW with 16 lcores # Run on all logical cores. # max_workers => MCE::Util::get_ncpu(), chunk_size => 2000, # Default 1 # Can also take a suffix; k (kibiBytes) or m (mebiBytes). # 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. # chunk_size => 1, # Consists of 1 record # chunk_size => 1000, # Consists of 1000 records # chunk_size => '16k', # Approximate 16 kibiBytes (KiB) # chunk_size => '20m', # Approximate 20 mebiBytes (MiB) 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 => $io # Process IO::All { File, Pipe, STDIO } # 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 => 20, # Default 0 # Added in 1.7, enables the manager process to timeout of a read # operation on channel 0 (UNIX platforms only). 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 dies unexpectedly (i.e. from an XS module). # Option works with init_relay on UNIX platforms since MCE 1.844. # 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 nodes with input coming # from shared storage. # Set posix_exit to avoid all END and destructor processing. # Constructing MCE inside a thread implies 1 or if present CGI, # FCGI, Coro, Curses, Gearman::Util, Gearman::XS, LWP::UserAgent, # Mojo::IOLoop, STFL, Tk, Wx, or Win32::GUI. # Enable slurpio to pass the raw chunk (scalar ref) to the user # function when reading input files. use_threads => 1, # Auto 0 or 1 # By default MCE spawns child processes on UNIX platforms and # threads on Windows (i.e. $^O eq 'MSWin32'). # MCE supports threads via two threading libraries if threads # is preferred over child processes. The use of threads requires # a thread library prior to loading MCE, causing the use_threads # option to default to 1. Specify 0 for child processes. # # use threads; use forks; # use threads::shared; use forks::shared; # use MCE (or) use MCE; (or) use MCE; spawn_delay => 0.045, # Default undef submit_delay => 0.015, # Default undef job_delay => 0.060, # Default undef # Time to wait in fractional seconds after spawning a worker, # after submitting parameters to worker (MCE->run, MCE->process), # and worker running (one time staggered delay). # Specify job_delay to stagger workers connecting to a database. on_post_exit => \&on_post_exit, # Default undef on_post_run => \&on_post_run, # Default undef # Execute the code block after a worker exits or dies. # (i.e. MCE->exit, exit, die) # Execute the code block after running. # (i.e. MCE->process, MCE->run) progress => sub { ... }, # Default undef # A code block for receiving info on the progress made. # See section labeled "MCE PROGRESS DEMONSTRATIONS" at the # end of this document. 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 HASH reference. Workers can access this directly. # (i.e. 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 => 0, # Default 1 flush_stderr => 0, # Default 1 flush_stdout => 0, # Default 1 # 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 - MCE CONSTANTS 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 init_relay => 0, # Default undef; MCE 1.882+ use_threads => 0, # Default undef; MCE 1.882+ ; my $mce = MCE->new( ... ); From MCE 1.8 onwards, Sereal 3.015+ is loaded automatically if available. Specify C<< Sereal => 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 array $mce->process(\@input_data_2); $mce->process(\@input_data_n); $mce->process(\%input_hash_1); # Process hash, current API $mce->process(\%input_hash_2); # available since 1.828 $mce->process(\%input_hash_n); $mce->process('input_file_1'); # Process file $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. C { File, Pipe, STDIO } is supported since MCE 1.845. input_data => '/path/to/file', # process file input_data => \@array, # process array input_data => \%hash, # process hash, API since 1.828 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 => $io, # IO::All { File, Pipe, STDIO } 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 kibiBytes (KiB) chunk_size => '20m', # Approximate 20 mebiBytes (MiB) 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"; } } # input_data => \%hash # current API available since 1.828 user_func => sub { my ($mce, $chunk_ref, $chunk_id) = @_; # $_ points to $chunk_ref regardless of chunk_size for my $key ( keys %{ $chunk_ref } ) { print "$key: ", $chunk_ref->{$key}, "\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, allows MCE to retry a failed chunk from a worker dying while processing input data or a sequence of numbers. When max_retries is set, MCE configures the on_post_exit option automatically using the following code before running. Specify on_post_exit explicitly for any further tailoring. The restart_worker line is necessary, obviously. on_post_exit => sub { my ( $mce, $e, $retry_cnt ) = @_; if ( $e->{id} ) { my $cnt = $retry_cnt + 1; my $msg = "Error: chunk $e->{id} failed"; if ( defined $mce->{init_relay} ) { print {*STDERR} "$msg, retrying chunk attempt # $cnt\n" if ( $retry_cnt < $mce->{max_retries} ); } else { ( $retry_cnt < $mce->{max_retries} ) ? print {*STDERR} "$msg, retrying chunk attempt # $cnt\n" : print {*STDERR} "$msg\n"; } $mce->restart_worker; } } We let MCE handle on_post_exit automatically below, which is essentially the same code shown above. For max_retries to work, the worker must die, abnormally included, or call MCE->exit. Notice that we pass the chunk_id value for the 3rd argument to MCE->exit (defaults to chunk_id if omitted since MCE 1.844). # max_retries demonstration use strict; use warnings; use MCE; sub user_func { my ( $mce, $chunk_ref, $chunk_id ) = @_; # die "Died : chunk_id = 3\n" if $chunk_id == 3; MCE->exit(1, undef, $chunk_id) if $chunk_id == 3; print "$chunk_id\n"; } my $mce = MCE->new( max_workers => 1, max_retries => 2, user_func => \&user_func, )->spawn; my $input_data = [ 0..7 ]; $mce->process( { chunk_size => 1 }, $input_data ); $mce->shutdown; -- Output 1 2 Error: chunk 3 failed, retrying chunk attempt # 1 Error: chunk 3 failed, retrying chunk attempt # 2 Error: chunk 3 failed 4 5 6 7 8 Orderly output with max_retries is possible since MCE 1.844. Below, chunk 3 succeeds whereas chunk 5 fails due to exceeding the number of retries. Be sure to call MCE::relay inside C and near the end of the block. # max_retries demonstration with init_relay use strict; use warnings; use MCE; use MCE::Shared; tie my $retries1, 'MCE::Shared', 0; tie my $retries2, 'MCE::Shared', 0; MCE->new( max_workers => 4, input_data => [ 1..7 ], chunk_size => 1, max_retries => 2, init_relay => 0, user_func => sub { if ( MCE->chunk_id == 3 ) { MCE->exit if ++$retries1 <= 2; } if ( MCE->chunk_id == 5 ) { MCE->exit if ++$retries2 <= 3; } MCE::relay { $_ += 1; print MCE->chunk_id, "\n"; }; } )->run; print "final: ", MCE::relay_final(), "\n"; -- Output 1 2 Error: chunk 3 failed, retrying chunk attempt # 1 Error: chunk 5 failed, retrying chunk attempt # 1 Error: chunk 3 failed, retrying chunk attempt # 2 Error: chunk 5 failed, retrying chunk attempt # 2 3 4 Error: chunk 5 failed 6 7 final: 6 =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 ) =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 ) =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 ) =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->do ( 'callback_func' [, $arg1, ... ] ) =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. Support for calling by the manager process was enabled in MCE 1.839. [ $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->freeze ( $object_ref ) =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 ) =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 ) =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 ) =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->printf ( $format, $list [, ... ] ) =head2 MCE->print ( $list [, ... ] ) =head2 MCE->say ( $list [, ... ] ) =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 and the manager process. 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 Sending to C { File, Pipe, STDIO } is supported since MCE 1.845. use IO::All; my $out = io->stdout; my $err = io->stderr; MCE->printf($out, "%s\n", "sent to stdout"); MCE->printf($err, "%s\n", "sent to stderr"); MCE->print($out, "sent to stdout\n"); MCE->print($err, "sent to stderr\n"); MCE->say($out, "sent to stdout"); MCE->say($err, "sent to stderr"); =head2 MCE->seed ( void ) =head2 $mce->seed ( void ) Returns the internal random generated seed or undefined. The seed is generated each time, prior to spawning a MCE session. Current API available since 1.895. =head2 MCE->sess_dir ( void ) =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 ) =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 ) =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 ) =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 ) =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 ) =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 ) =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 ) =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 { ... } ) =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 } ] ) =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 ) =head2 $mce->relay_final ( void ) The relay methods are described in L. Relay capabilities are enabled by specifying the C MCE option. =head2 MCE->restart_worker ( void ) =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 } ] ] ) =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 ) =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 ) =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 ) =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 ) =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->exit ( [ $status [, $message [, $id ] ] ] ) =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, ... ] ) =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 ) =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 ) =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::relay { code } =head2 MCE->relay ( sub { code } ) =head2 MCE->relay_recv ( void ) =head2 $mce->relay ( sub { code } ) =head2 $mce->relay_recv ( void ) The relay methods are described in L. Relay capabilities are enabled by specifying the C MCE option. =head2 MCE->sendto ( $to, $arg1, ... ) =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 ) =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 ) =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 MCE PROGRESS DEMONSTRATIONS The C option takes a code block for receiving info on the progress made while processing input data; e.g. C or C. To make this work, one provides the C option a closure block like so, passing along the size of the input_data; e.g C or C<-s /path/to/file>. Current API available since 1.813. A worker, upon completing processing its chunk, notifies the manager-process with the size of the chunk. That could be the number of rows or literally the size of the chunk when processing an input file. The manager-process accumulates the size before calling the code block associated with the C option. When running many tasks simultaneously, via C, the call is initiated by workers at level 0 only or rather the first task, not shown here. use Time::HiRes 'sleep'; use MCE; sub make_progress { my ($total_size) = @_; return sub { my ($completed_size) = @_; printf "%0.1f%%\n", $completed_size / $total_size * 100; }; } my @input = (1..150); MCE->new( chunk_size => 10, max_workers => 4, input_data => \@input, progress => make_progress( scalar @input ), user_func => sub { sleep 1.5 } )->run(); -- Output 6.7% 13.3% 20.0% 26.7% 33.3% 40.0% 46.7% 53.3% 60.0% 66.7% 73.3% 80.0% 86.7% 93.3% 100.0% Next is the code using L and L to do the same thing, practically. use Time::HiRes 'sleep'; use ProgressBar::Stack; use MCE::Flow; sub make_progress { my ($total_size) = @_; init_progress(); return sub { my ($completed_size) = @_; update_progress sprintf("%0.1f", $completed_size / $total_size * 100); }; } my @input = (1..150); MCE::Flow->init( chunk_size => 10, max_workers => 4, progress => make_progress( scalar @input ) ); MCE::Flow->run( sub { sleep 1.5 }, \@input ); MCE::Flow->finish(); print "\n"; -- Output [################ ] 80.0% ETA: 0:01 For sequence of numbers, using the C option, one must account for C, typically set to C<1> automatically. use Time::HiRes 'sleep'; use MCE; sub make_progress { my ($total_size) = @_; return sub { my ($completed_size) = @_; printf "%0.1f%%\n", $completed_size / $total_size * 100; }; } MCE->new( chunk_size => 10, max_workers => 4, sequence => [ 1, 100, 2 ], progress => make_progress( int( 100 / 2 + 0.5 ) ), user_func => sub { sleep 1.5 } )->run(); -- Output 20.0% 40.0% 60.0% 80.0% 100.0% Changing C to C<1> means workers notify the manager process more often, thus increasing granularity. Take a look at the output. 2.0% 4.0% 6.0% 8.0% 10.0% ... 92.0% 94.0% 96.0% 98.0% 100.0% Here is the same thing using L together with L. use Time::HiRes 'sleep'; use ProgressBar::Stack; use MCE::Flow; sub make_progress { my ($total_size) = @_; init_progress(); return sub { my ($completed_size) = @_; update_progress sprintf("%0.1f", $completed_size / $total_size * 100); }; } MCE::Flow->init( chunk_size => 1, max_workers => 4, progress => make_progress( int( 100 / 2 + 0.5 ) ) ); MCE::Flow->run_seq( sub { sleep 0.5 }, 1, 100, 2 ); MCE::Flow->finish(); print "\n"; -- Output [######### ] 48.0% ETA: 0:03 For files and file handles, workers send the actual size of the data read versus counting rows. use Time::HiRes 'sleep'; use MCE; sub make_progress { my ($total_size) = @_; return sub { my ($completed_size) = @_; printf "%0.1f%%\n", $completed_size / $total_size * 100; }; } my $input_file = "/path/to/input_file.txt"; MCE->new( chunk_size => 5, max_workers => 4, input_data => $input_file, progress => make_progress( -s $input_file ), user_func => sub { sleep 0.03 } )->run(); For consistency, here is the example using L, again with L. use Time::HiRes 'sleep'; use ProgressBar::Stack; use MCE::Flow; sub make_progress { my ($total_size) = @_; init_progress(); return sub { my ($completed_size) = @_; update_progress sprintf("%0.1f", $completed_size / $total_size * 100); }; } my $input_file = "/path/to/input_file.txt"; MCE::Flow->init( chunk_size => 5, max_workers => 4, progress => make_progress( -s $input_file ) ); MCE::Flow->run_file( sub { sleep 0.03 }, $input_file ); MCE::Flow->finish(); The next demonstration processes three arrays consecutively. For this one, MCE workers persist after running. This needs MCE 1.814 or later to run. Otherwise, the progress output is not shown in MCE 1.813. use Time::HiRes 'sleep'; use ProgressBar::Stack; use MCE; sub make_progress { my ($total_size, $message) = @_; init_progress(); return sub { my ($completed_size) = @_; update_progress( sprintf("%0.1f", $completed_size / $total_size * 100), $message ); }; } my $mce = MCE->new( chunk_size => 10, max_workers => 4, user_func => sub { sleep 0.5 } )->spawn(); my @a1 = ( 1 .. 200 ); my @a2 = ( 1 .. 500 ); my @a3 = ( 1 .. 300 ); $mce->process({ progress => make_progress(scalar(@a1), "array 1") }, \@a1); print "\n"; $mce->process({ progress => make_progress(scalar(@a2), "array 2") }, \@a2); print "\n"; $mce->process({ progress => make_progress(scalar(@a3), "array 3") }, \@a3); print "\n"; $mce->shutdown; -- Output [####################] 100.0% ETA: 0:00 array 1 [####################] 100.0% ETA: 0:00 array 2 [####################] 100.0% ETA: 0:00 array 3 When size is not know, such as reading from C, the only thing one can do is report the size completed thus far. # 1 kibibyte equals 1024 bytes progress => sub { my ($completed_size) = @_; printf "%0.1f kibibytes\n", $completed_size / 1024; } =head1 SEE ALSO =over 3 =item * L =back =head1 INDEX L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Map.pm000644 000765 000024 00000052355 14735610752 014653 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## 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.901'; ## 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 $_tid = $INC{'threads.pm'} ? threads->tid() : 0; sub CLONE { $_tid = threads->tid() if $INC{'threads.pm'}; } ############################################################################### ## ---------------------------------------------------------------------------- ## 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. if ($_pkg !~ /^MCE::/) { 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' ); $_p->{INIT_RELAY} = shift, next if ( $_arg eq 'init_relay' ); $_p->{USE_THREADS} = shift, next if ( $_arg eq 'use_threads' ); ## Sereal 3.015+, if available, is used automatically by MCE 1.8+. 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::_parse_max_workers($_p->{MAX_WORKERS}); MCE::_validate_number($_p->{MAX_WORKERS}, 'MAX_WORKERS', $_tag); MCE::_validate_number($_p->{CHUNK_SIZE}, 'CHUNK_SIZE', $_tag) 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 MCE::Map::_guard::DESTROY { my ($_pkg, $_id) = @{ $_[0] }; if (defined $_pkg && $_id eq "$$.$_tid") { @{ $_[0] } = (); MCE::Map->finish($_pkg); } return; } sub init (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Map'); my $_pkg = "$$.$_tid.".caller(); $_params->{$_pkg} = (ref $_[0] eq 'HASH') ? shift : { @_ }; _croak("$_tag: (HASH) not allowed as input by this MCE model") if ( ref $_params->{$_pkg}{input_data} eq 'HASH' ); @_ = (); defined wantarray ? bless([$_pkg, "$$.$_tid"], MCE::Map::_guard::) : (); } 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') { if (@{ $_[0] } > 3 && $_[0]->[3] =~ /\d$/) { $_begin = $_[0]->[0], $_end = $_[0]->[-1]; $_params->{$_pid}{sequence} = [ $_[0]->[0], $_[0]->[-1] ]; } else { $_begin = $_[0]->[0], $_end = $_[0]->[1]; $_params->{$_pid}{sequence} = $_[0]; } } elsif (ref $_[0] eq '' || ref($_[0]) =~ /^Math::/) { if (@_ > 3 && $_[3] =~ /\d$/) { $_begin = $_[0], $_end = $_[-1]; $_params->{$_pid}{sequence} = [ $_[0], $_[-1] ]; } else { $_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} = undef; @_ = (); 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 (@_ == 1 && $_r =~ /^(?:ARRAY|HASH|SCALAR|CODE|GLOB|FileHandle|IO::)/) { _croak("$_tag: (HASH) not allowed as input by this MCE model") if $_r eq 'HASH'; $_input_data = shift; } if (defined (my $_p = $_params->{$_pid})) { $_max_workers = MCE::_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 = do { my $_p = $_params->{$_pid} || {}; (defined $_p->{init_relay} || defined $_def->{$_pkg}{INIT_RELAY}) ? 1 : MCE::_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($_MCE->{$_pid}); 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("$_tag: ($_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 init_relay use_threads /) { $_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; } 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.901 =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 { $_ * $_ } \@list; ## Important; pass an array_ref for deeply input data my @c = mce_map { $_->[1] *= 2; $_ } [ [ 0, 1 ], [ 0, 2 ], ... ]; my @d = mce_map { $_->[1] *= 2; $_ } \@deeply_list; ## File path, glob ref, IO::All::{ File, Pipe, STDIO } obj, or scalar ref ## Workers read directly and not involve the manager process my @e = mce_map_f { chomp; $_ } "/path/to/file"; # efficient ## Involves the manager process, therefore slower my @f = mce_map_f { chomp; $_ } $file_handle; my @g = mce_map_f { chomp; $_ } $io; my @h = mce_map_f { chomp; $_ } \$scalar; ## Sequence of numbers (begin, end [, step, format]) my @i = mce_map_s { $_ * $_ } 1, 10000, 5; my @j = mce_map_s { $_ * $_ } [ 1, 10000, 5 ]; my @k = 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 init_relay => 0, # Default undef; MCE 1.882+ use_threads => 0, # Default undef; MCE 1.882+ ; From MCE 1.8 onwards, Sereal 3.015+ is loaded automatically if available. Specify C<< Sereal => 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 } =back The init function accepts a hash of MCE options. The gather option, if specified, is ignored due to being used internally by the module. In scalar context (API available since 1.897), call Cfinish> automatically upon leaving the scope or program. use MCE::Map; my $guard = 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 =head1 API DOCUMENTATION =over 3 =item MCE::Map->run ( sub { code }, list ) =item mce_map { code } list =back Input data may be defined using a list or an array reference. Unlike MCE::Loop, Flow, and Step, specifying a hash reference as input data isn't allowed. ## Array or array_ref my @a = mce_map { $_ * 2 } 1..1000; my @b = mce_map { $_ * 2 } \@list; ## Important; pass an array_ref for deeply input data my @c = mce_map { $_->[1] *= 2; $_ } [ [ 0, 1 ], [ 0, 2 ], ... ]; my @d = mce_map { $_->[1] *= 2; $_ } \@deeply_list; ## Not supported my @z = mce_map { ... } \%hash; =over 3 =item MCE::Map->run_file ( sub { code }, file ) =item mce_map_f { code } file =back The fastest of these is the /path/to/file. Workers communicate the next offset position among themselves with zero interaction by the manager process. C { File, Pipe, STDIO } is supported since MCE 1.845. my @c = mce_map_f { chomp; $_ . "\r\n" } "/path/to/file"; # faster my @d = mce_map_f { chomp; $_ . "\r\n" } $file_handle; my @e = mce_map_f { chomp; $_ . "\r\n" } $io; # IO::All my @f = mce_map_f { chomp; $_ . "\r\n" } \$scalar; =over 3 =item MCE::Map->run_seq ( sub { code }, $beg, $end [, $step, $fmt ] ) =item mce_map_s { code } $beg, $end [, $step, $fmt ] =back Sequence may 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 }; =over 3 =item MCE::Map->run ( sub { code }, iterator ) =item mce_map { code } iterator =back An iterator reference may be specified for input_data. Iterators are described under section "SYNTAX for INPUT_DATA" at L. my @a = mce_map { $_ * 2 } make_iterator(10, 30, 2); =head1 MANUAL SHUTDOWN =over 3 =item MCE::Map->finish =item MCE::Map::finish =back 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; =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Child.pm000644 000765 000024 00000161412 14735610752 015154 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## A threads-like parallelization module compatible with Perl 5.8. ## ############################################################################### use strict; use warnings; no warnings qw( threads recursion uninitialized once redefine ); package MCE::Child; our $VERSION = '1.901'; ## no critic (BuiltinFunctions::ProhibitStringyEval) ## no critic (Subroutines::ProhibitExplicitReturnUndef) ## no critic (Subroutines::ProhibitSubroutinePrototypes) ## no critic (TestingAndDebugging::ProhibitNoStrict) use MCE::Signal (); use MCE::Mutex (); use MCE::Channel (); use Time::HiRes 'sleep'; use overload ( q(==) => \&equal, q(!=) => sub { !equal(@_) }, fallback => 1 ); sub import { if (caller !~ /^MCE::/) { no strict 'refs'; no warnings 'redefine'; *{ caller().'::mce_child' } = \&mce_child; } return; } ## The POSIX module has many symbols. Try not loading it simply ## to have WNOHANG. The following covers most platforms. use constant { _WNOHANG => ( $INC{'POSIX.pm'} ) ? &POSIX::WNOHANG : ( $^O eq 'solaris' ) ? 64 : 1 }; my ( $_MNGD, $_DATA, $_DELY, $_LIST ) = ( {}, {}, {}, {} ); my $_is_MSWin32 = ( $^O eq 'MSWin32' ) ? 1 : 0; my $_tid = ( $INC{'threads.pm'} ) ? threads->tid() : 0; my $_yield_secs = ( $^O =~ /mswin|mingw|msys|cygwin/i ) ? 0.015 : 0.008; sub CLONE { $_tid = threads->tid(), &_clear() if $INC{'threads.pm'}; } sub _clear { %{ $_LIST } = (); } sub _max_workers { my ( $cpus ) = @_; if ( $cpus eq 'auto' ) { $cpus = MCE::Util::get_ncpu(); } elsif ( $cpus =~ /^([0-9.]+)%$/ ) { my ( $percent, $ncpu ) = ( $1 / 100, MCE::Util::get_ncpu() ); $cpus = $ncpu * $percent + 0.5; } $cpus = 1 if $cpus !~ /^[\d\.]+$/ || $cpus < 1; return int($cpus); } ############################################################################### ## ---------------------------------------------------------------------------- ## Init routine. ## ############################################################################### bless my $_SELF = { MGR_ID => "$$.$_tid", WRK_ID => $$ }, __PACKAGE__; sub MCE::Child::_guard::DESTROY { my ($pkg, $id) = @{ $_[0] }; if (defined $pkg && $id eq "$$.$_tid") { @{ $_[0] } = (); MCE::Child->finish($pkg); } return; } sub init { shift if ( defined $_[0] && $_[0] eq __PACKAGE__ ); # -- options ---------------------------------------------------------- # max_workers child_timeout posix_exit on_start on_finish void_context # --------------------------------------------------------------------- my $opt = ( ref $_[0] eq 'HASH' ) ? shift : { @_ }; my $pkg = "$$.$_tid.".( delete $opt->{caller} || caller() ); my $mngd = $_MNGD->{$pkg} = $opt; @_ = (); $mngd->{MGR_ID} = "$$.$_tid", $mngd->{PKG} = $pkg, $mngd->{WRK_ID} = $$; &_force_reap($pkg), $_DATA->{$pkg}->clear() if ( defined $_LIST->{$pkg} ); if ( !defined $_LIST->{$pkg} ) { $MCE::_GMUTEX->lock() if ( $_tid && $MCE::_GMUTEX ); sleep 0.015 if $_tid; # Start the shared-manager process if not running. MCE::Shared->start() if $INC{'MCE/Shared.pm'}; my $chnl = MCE::Channel->new( impl => 'Mutex' ); $_LIST->{ $pkg } = MCE::Child::_ordhash->new(); $_DELY->{ $pkg } = MCE::Child::_delay->new( $chnl ); $_DATA->{ $pkg } = MCE::Child::_hash->new( $chnl ); $_DATA->{"$pkg:id"} = 0; $_DATA->{"$pkg:seed"} = int(CORE::rand() * 1e9); $MCE::_GMUTEX->unlock() if ( $_tid && $MCE::_GMUTEX ); } if ( !exists $mngd->{posix_exit} ) { $mngd->{posix_exit} = 1 if ( $^S || $_tid || $INC{'Mojo/IOLoop.pm'} || $INC{'Coro.pm'} || $INC{'LWP/UserAgent.pm'} || $INC{'stfl.pm'} || $INC{'Curses.pm'} || $INC{'CGI.pm'} || $INC{'FCGI.pm'} || $INC{'Tk.pm'} || $INC{'Wx.pm'} || $INC{'Win32/GUI.pm'} || $INC{'Gearman/Util.pm'} || $INC{'Gearman/XS.pm'} ); } if ( defined $mngd->{max_workers} ) { $mngd->{max_workers} = _max_workers($mngd->{max_workers}); } if ( $INC{'LWP/UserAgent.pm'} && !$INC{'Net/HTTP.pm'} ) { local $@; eval 'require Net::HTTP; require Net::HTTPS'; } require POSIX if ( $mngd->{on_finish} && !$INC{'POSIX.pm'} && !$_is_MSWin32 ); defined wantarray ? bless([$pkg, "$$.$_tid"], MCE::Child::_guard::) : (); } ############################################################################### ## ---------------------------------------------------------------------------- ## 'new', 'mce_child', and 'create' for threads-like similarity. ## ############################################################################### ## 'new' and 'tid' are aliases for 'create' and 'pid' respectively. *new = \&create, *tid = \&pid; ## Use "goto" trick to avoid pad problems from 5.8.1 (fixed in 5.8.2) ## Tip found in threads::async. sub mce_child (&;@) { goto &create; } sub create { my $caller = caller(); my $mngd = $_MNGD->{ "$$.$_tid.$caller" } || do { # construct mngd internally on first use unless defined init( caller => $caller ); $_MNGD->{ "$$.$_tid.$caller" }; }; shift if ( $_[0] eq __PACKAGE__ ); # ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ my $self = bless ref $_[0] eq 'HASH' ? { %{ shift() } } : { }, __PACKAGE__; $self->{IGNORE} = 1 if $SIG{CHLD} eq 'IGNORE'; $self->{MGR_ID} = $mngd->{MGR_ID}, $self->{PKG} = $mngd->{PKG}; $self->{ident } = shift if ( !ref $_[0] && ref $_[1] eq 'CODE' ); my $func = shift; $func = $caller.'::'.$func if ( !ref $func && length $func && index($func,':') < 0 ); if ( !defined $func ) { local $\; print {*STDERR} "code function is not specified or valid\n"; return undef; } my ( $list, $max_workers, $pkg ) = ( $_LIST->{ $mngd->{PKG} }, $mngd->{max_workers}, $mngd->{PKG} ); $_DATA->{"$pkg:id"} = 10000 if ( ( my $id = ++$_DATA->{"$pkg:id"} ) >= 2e9 ); # Reap completed child processes. { local ($SIG{CHLD}, $!, $?, $_); map { $_ = substr($_, 1); # strip leading 'R' my $child = $list->del($_); if ( ! $child->{REAPED} ) { waitpid($child->{WRK_ID}, 0); _reap_child($child, 0); } (); } $_DATA->{$pkg}->get_done(); } # Wait for a slot if saturated. _wait_one($pkg) if ( $max_workers && $list->len() >= $max_workers ); # ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ ~~~ $MCE::_GMUTEX->lock() if ( $_tid && $MCE::_GMUTEX ); my @args = @_; @_ = (); # To avoid (Scalars leaked: N) messages my ( $killed, $pid ); { local $SIG{TERM} = local $SIG{INT} = sub { $killed = $_[0] } if ( !$_is_MSWin32 && $] ge '5.010001' ); local $SIG{TTIN}, local $SIG{TTOU}, local $SIG{WINCH} if ( !$_is_MSWin32 ); $pid = fork(); if ( !defined $pid ) { # error local $\; print {*STDERR} "fork error: $!\n"; } elsif ( $pid ) { # parent $self->{WRK_ID} = $pid; $list->set($pid, $self); $mngd->{on_start}->($pid, $self->{ident}) if $mngd->{on_start}; } else { # child %{ $_LIST } = (), $_SELF = $self; local $SIG{TERM} = local $SIG{INT} = local $SIG{ABRT} = \&_trap, local $SIG{SEGV} = local $SIG{HUP} = \&_trap, local $SIG{QUIT} = \&_quit; local $SIG{CHLD}; MCE::Shared::init() if $INC{'MCE/Shared.pm'}; $_DATA->{ $_SELF->{PKG} }->set('S'.$$, '') unless $self->{IGNORE}; CORE::kill($killed, $$) if $killed; MCE::Child->_clear() if $INC{'MCE/Child.pm'}; MCE::Hobo->_clear() if $INC{'MCE/Hobo.pm'}; # Set the seed of the base generator uniquely between workers. # The new seed is computed using the current seed and ID value. # One may set the seed at the application level for predictable # results. Ditto for PDL, Math::Prime::Util, Math::Random, and # Math::Random::MT::Auto. { my $seed = abs($_DATA->{"$pkg:seed"} - ($id * 100000)) % 2147483560; CORE::srand($seed); PDL::srand($seed) if $INC{'PDL.pm'} && PDL->can('srand'); # PDL 2.062 ~ 2.089 PDL::srandom($seed) if $INC{'PDL.pm'} && PDL->can('srandom'); # PDL 2.089_01+ Math::Prime::Util::srand($seed) if $INC{'Math/Prime/Util.pm'}; } if ( $INC{'Math/Random.pm'} ) { my $cur_seed = Math::Random::random_get_seed(); my $new_seed = ($cur_seed < 1073741781) ? $cur_seed + ((abs($id) * 10000) % 1073741780) : $cur_seed - ((abs($id) * 10000) % 1073741780); Math::Random::random_set_seed($new_seed, $new_seed); } if ( $INC{'Math/Random/MT/Auto.pm'} ) { my $cur_seed = Math::Random::MT::Auto::get_seed()->[0]; my $new_seed = ($cur_seed < 1073741781) ? $cur_seed + ((abs($id) * 10000) % 1073741780) : $cur_seed - ((abs($id) * 10000) % 1073741780); Math::Random::MT::Auto::set_seed($new_seed); } _dispatch($mngd, $func, \@args); } } $MCE::_GMUTEX->unlock() if ( $_tid && $MCE::_GMUTEX ); CORE::kill($killed, $$) if $killed; return $pid ? $self : undef; } ############################################################################### ## ---------------------------------------------------------------------------- ## Public methods. ## ############################################################################### sub equal { return 0 unless ( ref $_[0] && ref $_[1] ); $_[0]->{WRK_ID} == $_[1]->{WRK_ID} ? 1 : 0; } sub error { _croak('Usage: $child->error()') unless ref( my $self = $_[0] ); $self->join() unless $self->{REAPED}; $self->{ERROR} || undef; } sub exit { shift if ( defined $_[0] && $_[0] eq __PACKAGE__ ); my ( $self ) = ( ref $_[0] ? shift : $_SELF ); my ( $pkg, $wrk_id ) = ( $self->{PKG}, $self->{WRK_ID} ); if ( $wrk_id == $$ && $self->{MGR_ID} eq "$$.$_tid" ) { MCE::Child->finish('MCE'); CORE::exit(@_); } elsif ( $wrk_id == $$ ) { alarm 0; my ( $exit_status, @res ) = @_; $? = $exit_status || 0; $_DATA->{$pkg}->set('R'.$wrk_id, @res ? \@res : '') unless $self->{IGNORE}; die "Child exited ($?)\n"; _exit($?); # not reached } return $self if $self->{REAPED}; if ( defined $_DATA->{$pkg} ) { sleep $_yield_secs until $_DATA->{$pkg}->exists('S'.$wrk_id); } else { sleep 0.030; } if ($_is_MSWin32) { CORE::kill('KILL', $wrk_id) if CORE::kill('ZERO', $wrk_id); } else { CORE::kill('QUIT', $wrk_id) if CORE::kill('ZERO', $wrk_id); } $self; } sub finish { _croak('Usage: MCE::Child->finish()') if ref($_[0]); shift if ( defined $_[0] && $_[0] eq __PACKAGE__ ); my $pkg = defined($_[0]) ? shift : "$$.$_tid.".caller(); if ( $pkg eq 'MCE' ) { for my $key ( keys %{ $_LIST } ) { MCE::Child->finish($key); } } elsif ( defined $_LIST->{$pkg} ) { return if $MCE::Signal::KILLED; if ( exists $_DELY->{$pkg} ) { &_force_reap($pkg); delete($_DELY->{$pkg}), delete($_DATA->{"$pkg:seed"}), delete($_LIST->{$pkg}), delete($_DATA->{"$pkg:id"}), delete($_MNGD->{$pkg}), delete($_DATA->{ $pkg }); } } @_ = (); return; } sub is_joinable { _croak('Usage: $child->is_joinable()') unless ref( my $self = $_[0] ); my ( $wrk_id, $pkg ) = ( $self->{WRK_ID}, $self->{PKG} ); if ( $wrk_id == $$ ) { ''; } elsif ( $self->{MGR_ID} eq "$$.$_tid" ) { return '' if $self->{REAPED}; local $!; $_DATA->{$pkg}->reap_data; ( waitpid($wrk_id, _WNOHANG) == 0 ) ? '' : do { _reap_child($self, 0) unless $self->{REAPED}; 1; }; } else { # limitation for MCE::Child only; allowed for MCE::Hobo _croak('Error: $child->is_joinable() not called by managed process'); } } sub is_running { _croak('Usage: $child->is_running()') unless ref( my $self = $_[0] ); my ( $wrk_id, $pkg ) = ( $self->{WRK_ID}, $self->{PKG} ); if ( $wrk_id == $$ ) { 1; } elsif ( $self->{MGR_ID} eq "$$.$_tid" ) { return '' if $self->{REAPED}; local $!; $_DATA->{$pkg}->reap_data; ( waitpid($wrk_id, _WNOHANG) == 0 ) ? 1 : do { _reap_child($self, 0) unless $self->{REAPED}; ''; }; } else { # limitation for MCE::Child only; allowed for MCE::Hobo _croak('Error: $child->is_running() not called by managed process'); } } sub join { _croak('Usage: $child->join()') unless ref( my $self = $_[0] ); my ( $wrk_id, $pkg ) = ( $self->{WRK_ID}, $self->{PKG} ); if ( $self->{REAPED} ) { _croak('Child already joined') unless exists( $self->{RESULT} ); $_LIST->{$pkg}->del($wrk_id) if ( defined $_LIST->{$pkg} ); return ( defined wantarray ) ? wantarray ? @{ delete $self->{RESULT} } : delete( $self->{RESULT} )->[-1] : (); } if ( $wrk_id == $$ ) { _croak('Cannot join self'); } elsif ( $self->{MGR_ID} eq "$$.$_tid" ) { # remove from list after reaping local $SIG{CHLD}; _reap_child($self, 1); $_LIST->{$pkg}->del($wrk_id); } else { # limitation for MCE::Child only; allowed for MCE::Hobo _croak('Error: $child->join() not called by managed process'); } return unless ( exists $self->{RESULT} ); ( defined wantarray ) ? wantarray ? @{ delete $self->{RESULT} } : delete( $self->{RESULT} )->[-1] : (); } sub kill { _croak('Usage: $child->kill()') unless ref( my $self = $_[0] ); my ( $wrk_id, $pkg, $signal ) = ( $self->{WRK_ID}, $self->{PKG}, $_[1] ); if ( $wrk_id == $$ ) { CORE::kill($signal || 'INT', $$); return $self; } if ( $self->{MGR_ID} eq "$$.$_tid" ) { return $self if $self->{REAPED}; if ( defined $_DATA->{$pkg} ) { sleep $_yield_secs until $_DATA->{$pkg}->exists('S'.$wrk_id); } else { sleep 0.030; } } CORE::kill($signal || 'INT', $wrk_id) if CORE::kill('ZERO', $wrk_id); $self; } sub list { _croak('Usage: MCE::Child->list()') if ref($_[0]); my $pkg = "$$.$_tid.".caller(); ( defined $_LIST->{$pkg} ) ? $_LIST->{$pkg}->vals() : (); } sub list_pids { _croak('Usage: MCE::Child->list_pids()') if ref($_[0]); my $pkg = "$$.$_tid.".caller(); local $_; ( defined $_LIST->{$pkg} ) ? map { $_->pid } $_LIST->{$pkg}->vals() : (); } sub list_joinable { _croak('Usage: MCE::Child->list_joinable()') if ref($_[0]); my $pkg = "$$.$_tid.".caller(); return () unless ( my $list = $_LIST->{$pkg} ); local ($!, $?, $_); $_DATA->{$pkg}->reap_data; map { ( waitpid($_->{WRK_ID}, _WNOHANG) == 0 ) ? () : do { _reap_child($_, 0) unless $_->{REAPED}; $_; }; } $list->vals(); } sub list_running { _croak('Usage: MCE::Child->list_running()') if ref($_[0]); my $pkg = "$$.$_tid.".caller(); return () unless ( my $list = $_LIST->{$pkg} ); local ($!, $?, $_); $_DATA->{$pkg}->reap_data; map { ( waitpid($_->{WRK_ID}, _WNOHANG) == 0 ) ? $_ : do { _reap_child($_, 0) unless $_->{REAPED}; (); }; } $list->vals(); } sub max_workers { _croak('Usage: MCE::Child->max_workers()') if ref($_[0]); my $mngd = $_MNGD->{ "$$.$_tid.".caller() } || do { # construct mngd internally on first use unless defined init(); $_MNGD->{ "$$.$_tid.".caller() }; }; shift if ( $_[0] eq __PACKAGE__ ); $mngd->{max_workers} = _max_workers(shift) if @_; $mngd->{max_workers}; } sub pending { _croak('Usage: MCE::Child->pending()') if ref($_[0]); my $pkg = "$$.$_tid.".caller(); ( defined $_LIST->{$pkg} ) ? $_LIST->{$pkg}->len() : 0; } sub pid { ref($_[0]) ? $_[0]->{WRK_ID} : $_SELF->{WRK_ID}; } sub result { _croak('Usage: $child->result()') unless ref( my $self = $_[0] ); return $self->join() unless $self->{REAPED}; _croak('Child already joined') unless exists( $self->{RESULT} ); wantarray ? @{ delete $self->{RESULT} } : delete( $self->{RESULT} )->[-1]; } sub seed { _croak('Usage: MCE::Child->seed()') if ref($_[0]); my $pkg = exists $_SELF->{PKG} ? $_SELF->{PKG} : "$$.$_tid.".caller(); return $_DATA->{"$pkg:seed"}; } sub self { ref($_[0]) ? $_[0] : $_SELF; } sub wait_all { _croak('Usage: MCE::Child->wait_all()') if ref($_[0]); my $pkg = "$$.$_tid.".caller(); return wantarray ? () : 0 if ( !defined $_LIST->{$pkg} || !$_LIST->{$pkg}->len() ); local $_; ( wantarray ) ? map { $_->join(); $_ } $_LIST->{$pkg}->vals() : map { $_->join(); () } $_LIST->{$pkg}->vals(); } *waitall = \&wait_all; # compatibility sub wait_one { _croak('Usage: MCE::Child->wait_one()') if ref($_[0]); my $pkg = "$$.$_tid.".caller(); return undef if ( !defined $_LIST->{$pkg} || !$_LIST->{$pkg}->len() ); _wait_one($pkg); } *waitone = \&wait_one; # compatibility sub yield { _croak('Usage: MCE::Child->yield()') if ref($_[0]); shift if ( defined $_[0] && $_[0] eq __PACKAGE__ ); my $pkg = $_SELF->{PKG} || do { my $mngd = $_MNGD->{ "$$.$_tid.".caller() } || do { # construct mngd internally on first use unless defined init(); $_MNGD->{ "$$.$_tid.".caller() }; }; $mngd->{PKG}; }; return unless $_DELY->{$pkg}; my $seconds = $_DELY->{$pkg}->seconds(@_); MCE::Util::_sleep( $seconds ); } ############################################################################### ## ---------------------------------------------------------------------------- ## Private methods. ## ############################################################################### sub _croak { if ( $INC{'MCE.pm'} ) { goto &MCE::_croak; } else { $SIG{__DIE__} = \&MCE::Signal::_die_handler; $SIG{__WARN__} = \&MCE::Signal::_warn_handler; $\ = undef; goto &Carp::croak; } } sub _dispatch { my ( $mngd, $func, $args ) = @_; $mngd->{WRK_ID} = $_SELF->{WRK_ID} = $$, $? = 0; $ENV{PERL_MCE_IPC} = 'win32' if $_is_MSWin32; { local $!; (*STDERR)->autoflush(1) if defined( fileno *STDERR ); (*STDOUT)->autoflush(1) if defined( fileno *STDOUT ); } # Run task. my $child_timeout = ( exists $_SELF->{child_timeout} ) ? $_SELF->{child_timeout} : $mngd->{child_timeout}; my $void_context = ( exists $_SELF->{void_context} ) ? $_SELF->{void_context} : $mngd->{void_context}; my @res; my $timed_out = 0; local $SIG{'ALRM'} = sub { alarm 0; $timed_out = 1; $SIG{__WARN__} = sub {}; die "Child timed out\n"; }; if ( $void_context || $_SELF->{IGNORE} ) { no strict 'refs'; eval { alarm($child_timeout || 0); $func->(@{ $args }) }; } else { no strict 'refs'; @res = eval { alarm($child_timeout || 0); $func->(@{ $args }) }; } alarm 0; $@ = "Child timed out" if $timed_out; if ( $@ ) { _exit($?) if ( $@ =~ /^Child exited \(\S+\)$/ ); my $err = $@; $? = 1; $err =~ s/, <__ANONIO__> line \d+//; if ( ! $_SELF->{IGNORE} ) { $_DATA->{ $_SELF->{PKG} }->set('S'.$$, $err), $_DATA->{ $_SELF->{PKG} }->set('R'.$$, ''); } if ( !$timed_out && !$mngd->{on_finish} && !$INC{'MCE/Simple.pm'} ) { use bytes; warn "Child $$ terminated abnormally: reason $err\n"; } } else { shift(@res) if ref($res[0]) =~ /^MCE::(?:Barrier|Semaphore)::_guard/s; $_DATA->{ $_SELF->{PKG} }->set('R'.$$, @res ? \@res : '') if ( ! $_SELF->{IGNORE} ); } _exit($?); } sub _exit { my ( $exit_status ) = @_; # Check for nested workers not yet joined. MCE::Child->finish('MCE') if ( !$_SELF->{SIGNALED} && keys %{ $_LIST } ); # Exit child process. $SIG{__DIE__} = sub {} unless $_tid; $SIG{__WARN__} = sub {}; threads->exit($exit_status) if ( $INC{'threads.pm'} && $_is_MSWin32 ); CORE::kill('KILL', $$) if ( $_SELF->{SIGNALED} && !$_is_MSWin32 ); my $posix_exit = ( exists $_SELF->{posix_exit} ) ? $_SELF->{posix_exit} : $_MNGD->{ $_SELF->{PKG} }{posix_exit}; if ( $posix_exit && !$_is_MSWin32 ) { eval { MCE::Mutex::Channel::_destroy() }; POSIX::_exit($exit_status) if $INC{'POSIX.pm'}; CORE::kill('KILL', $$); } CORE::exit($exit_status); } sub _force_reap { my ( $count, $pkg ) = ( 0, @_ ); return unless ( defined $_LIST->{$pkg} && $_LIST->{$pkg}->len() ); for my $child ( $_LIST->{$pkg}->vals() ) { next if $child->{IGNORE}; if ( $child->is_running() ) { sleep($_yield_secs), CORE::kill('KILL', $child->pid()) if CORE::kill('ZERO', $child->pid()); $count++; } } $_LIST->{$pkg}->clear(); warn "Finished with active child processes [$pkg] ($count)\n" if ( $count && !$_is_MSWin32 ); return; } sub _quit { return MCE::Signal::defer($_[0]) if $MCE::Signal::IPC; alarm 0; my ( $name ) = @_; $_SELF->{SIGNALED} = 1, $name =~ s/^SIG//; $SIG{$name} = sub {}, CORE::kill($name, -$$) if ( exists $SIG{$name} ); if ( ! $_SELF->{IGNORE} ) { my ( $pkg, $wrk_id ) = ( $_SELF->{PKG}, $_SELF->{WRK_ID} ); $_DATA->{$pkg}->set('R'.$wrk_id, ''); } _exit(0); } sub _reap_child { my ( $child, $wait_flag ) = @_; return if ( !$child || !defined $child->{PKG} ); local @_ = $_DATA->{ $child->{PKG} }->get($child->{WRK_ID}, $wait_flag); ( $child->{ERROR}, $child->{RESULT}, $child->{REAPED} ) = ( pop || '', length $_[0] ? pop : [], 1 ); return if $child->{IGNORE}; my ( $exit, $err ) = ( $? || 0, $child->{ERROR} ); my ( $code, $sig ) = ( $exit >> 8, $exit & 0x7f ); if ( $code > 100 && !$err ) { $code = 2, $sig = 1, $err = 'Child received SIGHUP' if $code == 101; $code = 2, $sig = 2, $err = 'Child received SIGINT' if $code == 102; $code = 2, $sig = 6, $err = 'Child received SIGABRT' if $code == 106; $code = 2, $sig = 11, $err = 'Child received SIGSEGV' if $code == 111; $code = 2, $sig = 15, $err = 'Child received SIGTERM' if $code == 115; $child->{ERROR} = $err; } if ( my $on_finish = $_MNGD->{ $child->{PKG} }{on_finish} ) { $on_finish->( $child->{WRK_ID}, $code, $child->{ident}, $sig, $err, @{ $child->{RESULT} } ); } return; } sub _trap { return MCE::Signal::defer($_[0]) if $MCE::Signal::IPC; alarm 0; my ( $exit_status, $name ) = ( 2, @_ ); $_SELF->{SIGNALED} = 1, $name =~ s/^SIG//; $SIG{$name} = sub {}, CORE::kill($name, -$$) if ( exists $SIG{$name} ); if ( $name eq 'HUP' ) { $exit_status = 101 } elsif ( $name eq 'INT' ) { $exit_status = 102 } elsif ( $name eq 'ABRT' ) { $exit_status = 106 } elsif ( $name eq 'SEGV' ) { $exit_status = 111 } elsif ( $name eq 'TERM' ) { $exit_status = 115 } if ( ! $_SELF->{IGNORE} ) { my ( $pkg, $wrk_id ) = ( $_SELF->{PKG}, $_SELF->{WRK_ID} ); $_DATA->{$pkg}->set('R'.$wrk_id, ''); } _exit($exit_status); } sub _wait_one { my ( $pkg ) = @_; my ( $list, $self, $wrk_id ) = ( $_LIST->{$pkg} ); local $!; while () { $_DATA->{$pkg}->reap_data; for my $child ( $list->vals() ) { $wrk_id = $child->{WRK_ID}; return $list->del($wrk_id) if $child->{REAPED}; $self = $list->del($wrk_id), last if waitpid($wrk_id, _WNOHANG); } last if $self; sleep $_yield_secs; } _reap_child($self, 0); $self; } ############################################################################### ## ---------------------------------------------------------------------------- ## Delay implementation suited for MCE::Child. ## ############################################################################### package # hide from rpm MCE::Child::_delay; sub new { my ( $class, $chnl, $delay ) = @_; if ( !defined $delay ) { $delay = ($^O =~ /mswin|mingw|msys|cygwin/i) ? 0.015 : 0.008; } $chnl->send(undef); bless [ $delay, $chnl ], $class; } sub seconds { my ( $self, $how_long ) = @_; my $delay = defined($how_long) ? $how_long : $self->[0]; my $lapse = $self->[1]->recv(); my $time = MCE::Util::_time(); if ( !$delay || !defined $lapse ) { $lapse = $time; } elsif ( $lapse + $delay - $time < 0 ) { $lapse += int( abs($time - $lapse) / $delay + 0.5 ) * $delay; } $self->[1]->send( $lapse += $delay ); return $lapse - $time; } ############################################################################### ## ---------------------------------------------------------------------------- ## Hash and ordhash implementations suited for MCE::Child. ## ############################################################################### package # hide from rpm MCE::Child::_hash; use Time::HiRes 'sleep'; use constant { _WNOHANG => ( $INC{'POSIX.pm'} ) ? &POSIX::WNOHANG : ( $^O eq 'solaris' ) ? 64 : 1 }; sub new { my ( $class, $chnl ) = @_; bless [ {}, $chnl ], shift; } sub clear { my ( $self ) = @_; 1 while ( $self->[1]->recv2_nb() ); %{ $self->[0] } = (); } sub exists { my ( $self, $key ) = @_; $self->reap_data; CORE::exists $self->[0]{ $key }; } sub get_done { my ( $self ) = @_; my @ret; $self->reap_data; for my $key (keys %{ $self->[0] }) { push @ret, $key if ( substr($key, 0, 1) eq 'R' ); } return @ret; } sub get { my ( $self, $wrk_id, $wait_flag ) = @_; $self->reap_data if ( !CORE::exists $self->[0]{ 'R'.$wrk_id } ); if ( $wait_flag ) { local $!; ( CORE::exists $self->[0]{ 'R'.$wrk_id } ) ? waitpid($wrk_id, 0) : do { while () { my $data = $self->[1]->recv2_nb(); if ( !defined $data ) { last if waitpid($wrk_id, _WNOHANG); sleep(0.0009), next; } $self->[0]{ $data->[0] } = $data->[1]; waitpid($wrk_id, 0), last if $data->[0] eq 'R'.$wrk_id; } $self->reap_data if ( !CORE::exists $self->[0]{ 'R'.$wrk_id } ); }; } my $result = delete $self->[0]{ 'R'.$wrk_id }; my $error = delete $self->[0]{ 'S'.$wrk_id }; $result = '' unless ( defined $result ); $error = '' unless ( defined $error ); return ( $result, $error ); } sub reap_data { my ( $self ) = @_; while ( my $data = $self->[1]->recv2_nb() ) { $self->[0]{ $data->[0] } = $data->[1]; } return; } sub set { $_[0]->[1]->send2([ $_[1], $_[2] ]); } package # hide from rpm MCE::Child::_ordhash; sub new { bless [ {}, [], {}, 0 ], shift; } # data, keys, indx, gcnt sub exists { CORE::exists $_[0]->[0]{ $_[1] }; } sub get { $_[0]->[0]{ $_[1] }; } sub len { scalar keys %{ $_[0]->[0] }; } sub clear { my ( $self ) = @_; %{ $self->[0] } = @{ $self->[1] } = %{ $self->[2] } = (), $self->[3] = 0; return; } sub del { my ( $self, $key ) = @_; return undef unless defined( my $off = delete $self->[2]{$key} ); # tombstone $self->[1][$off] = undef; # GC keys and refresh index if ( ++$self->[3] > @{ $self->[1] } * 0.667 ) { my ( $keys, $indx ) = ( $self->[1], $self->[2] ); my $i; $i = $self->[3] = 0; for my $k ( @{ $keys } ) { $keys->[$i] = $k, $indx->{$k} = $i++ if defined($k); } splice @{ $keys }, $i; } delete $self->[0]{$key}; } sub set { my ( $self, $key ) = @_; $self->[0]{$key} = $_[2], return 1 if exists($self->[0]{$key}); $self->[2]{$key} = @{ $self->[1] }; push @{ $self->[1] }, $key; $self->[0]{$key} = $_[2]; return 1; } sub vals { my ( $self ) = @_; $self->[3] ? @{ $self->[0] }{ grep defined($_), @{ $self->[1] } } : @{ $self->[0] }{ @{ $self->[1] } }; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Child - A threads-like parallelization module compatible with Perl 5.8 =head1 VERSION This document describes MCE::Child version 1.901 =head1 SYNOPSIS use MCE::Child; MCE::Child->init( max_workers => 'auto', # default undef, unlimited # Specify a percentage. MCE::Child 1.876+. max_workers => '25%', # 4 on HW with 16 lcores max_workers => '50%', # 8 on HW with 16 lcores child_timeout => 20, # default undef, no timeout posix_exit => 1, # default undef, CORE::exit void_context => 1, # default undef on_start => sub { my ( $pid, $ident ) = @_; ... }, on_finish => sub { my ( $pid, $exit, $ident, $signal, $error, @ret ) = @_; ... } ); MCE::Child->create( sub { print "Hello from child\n" } )->join(); sub parallel { my ($arg1) = @_; print "Hello again, $arg1\n" if defined($arg1); print "Hello again, $_\n"; # same thing } MCE::Child->create( \¶llel, $_ ) for 1 .. 3; my @procs = MCE::Child->list(); my @pids = MCE::Child->list_pids(); my @running = MCE::Child->list_running(); my @joinable = MCE::Child->list_joinable(); my @count = MCE::Child->pending(); # Joining is orderly, e.g. child1 is joined first, child2, child3. $_->join() for @procs; # (or) $_->join() for @joinable; # Joining occurs immediately as child processes complete execution. 1 while MCE::Child->wait_one(); my $child = mce_child { foreach (@files) { ... } }; $child->join(); if ( my $err = $child->error() ) { warn "Child error: $err\n"; } # Get a child's object $child = MCE::Child->self(); # Get a child's ID $pid = MCE::Child->pid(); # $$ $pid = $child->pid(); $pid = MCE::Child->tid(); # tid is an alias for pid $pid = $child->tid(); # Test child objects if ( $child1 == $child2 ) { ... } # Give other workers a chance to run MCE::Child->yield(); MCE::Child->yield(0.05); # Return context, wantarray aware my ($value1, $value2) = $child->join(); my $value = $child->join(); # Check child's state if ( $child->is_running() ) { sleep 1; } if ( $child->is_joinable() ) { $child->join(); } # Send a signal to a child $child->kill('SIGUSR1'); # Exit a child MCE::Child->exit(0); MCE::Child->exit(0, @ret); =head1 DESCRIPTION L is a fork of L for compatibility with Perl 5.8. A child is a migratory worker inside the machine that carries the asynchronous gene. Child processes are equipped with C-like capability for running code asynchronously. Unlike threads, each child is a unique process to the underlying OS. The IPC is handled via C, which runs on all the major platforms including Cygwin and Strawberry Perl. C may be used as a standalone or together with C including running alongside C. use MCE::Child; use MCE::Shared; # synopsis: head -20 file.txt | perl script.pl my $ifh = MCE::Shared->handle( "<", \*STDIN ); # shared my $ofh = MCE::Shared->handle( ">", \*STDOUT ); my $ary = MCE::Shared->array(); sub parallel_task { my ( $id ) = @_; while ( <$ifh> ) { printf {$ofh} "[ %4d ] %s", $., $_; # $ary->[ $. - 1 ] = "[ ID $id ] read line $.\n" ); # dereferencing $ary->set( $. - 1, "[ ID $id ] read line $.\n" ); # faster via OO } } my $child1 = MCE::Child->new( "parallel_task", 1 ); my $child2 = MCE::Child->new( \¶llel_task, 2 ); my $child3 = MCE::Child->new( sub { parallel_task(3) } ); $_->join for MCE::Child->list(); # ditto: MCE::Child->wait_all(); # search array (total one round-trip via IPC) my @vals = $ary->vals( "val =~ / ID 2 /" ); print {*STDERR} join("", @vals); =head1 API DOCUMENTATION =over 3 =item $child = MCE::Child->create( FUNCTION, ARGS ) =item $child = MCE::Child->new( FUNCTION, ARGS ) This will create a new child process that will begin execution with function as the entry point, and optionally ARGS for list of parameters. It will return the corresponding MCE::Child object, or undef if child creation failed. I may either be the name of a function, an anonymous subroutine, or a code ref. my $child = MCE::Child->create( "func_name", ... ); # or my $child = MCE::Child->create( sub { ... }, ... ); # or my $child = MCE::Child->create( \&func, ... ); =item $child = MCE::Child->create( { options }, FUNCTION, ARGS ) =item $child = MCE::Child->create( IDENT, FUNCTION, ARGS ) Options, excluding C, may be specified globally via the C function. Otherwise, C, C, C, and C may be set uniquely. The C option is used by callback functions C and C for identifying the started and finished child process respectively. my $child1 = MCE::Child->create( { posix_exit => 1 }, sub { ... } ); $child1->join; my $child2 = MCE::Child->create( { child_timeout => 3 }, sub { sleep 1 for ( 1 .. 9 ); } ); $child2->join; if ( $child2->error() eq "Child timed out\n" ) { ... } The C method is an alias for C. =item mce_child { BLOCK } ARGS; =item mce_child { BLOCK }; C runs the block asynchronously similarly to C<< MCE::Child->create() >>. It returns the child object, or undef if child creation failed. my $child = mce_child { foreach (@files) { ... } }; $child->join(); if ( my $err = $child->error() ) { warn("Child error: $err\n"); } =item $child->join() This will wait for the corresponding child process to complete its execution. In non-voided context, C will return the value(s) of the entry point function. The context (void, scalar or list) for the return value(s) for C is determined at the time of joining and mostly C aware. my $child1 = MCE::Child->create( sub { my @res = qw(foo bar baz); return (@res); }); my @res1 = $child1->join(); # ( foo, bar, baz ) my $res1 = $child1->join(); # baz my $child2 = MCE::Child->create( sub { return 'foo'; }); my @res2 = $child2->join(); # ( foo ) my $res2 = $child2->join(); # foo =item $child1->equal( $child2 ) Tests if two child objects are the same child or not. Child comparison is based on process IDs. This is overloaded to the more natural forms. if ( $child1 == $child2 ) { print("Child objects are the same\n"); } # or if ( $child1 != $child2 ) { print("Child objects differ\n"); } =item $child->error() Child processes are executed in an C context. This method will return C if the child terminates I. Otherwise, it returns the value of C<$@> associated with the child's execution status in its C context. =item $child->exit() This sends C<'SIGQUIT'> to the child process, notifying the child to exit. It returns the child object to allow for method chaining. It is important to join later if not immediately to not leave a zombie or defunct process. $child->exit()->join(); ... $child->join(); # later =item MCE::Child->exit( 0 ) =item MCE::Child->exit( 0, @ret ) A child can exit at any time by calling C<< MCE::Child->exit() >>. Otherwise, the behavior is the same as C when called from the main process. The child process may optionally return data, to be sent via IPC. =item MCE::Child->finish() This class method is called automatically by C, but may be called explicitly. An error is emitted via croak if there are active child processes not yet joined. MCE::Child->create( 'task1', $_ ) for 1 .. 4; $_->join for MCE::Child->list(); MCE::Child->create( 'task2', $_ ) for 1 .. 4; $_->join for MCE::Child->list(); MCE::Child->create( 'task3', $_ ) for 1 .. 4; $_->join for MCE::Child->list(); MCE::Child->finish(); =item MCE::Child->init( options ) The init function accepts a list of MCE::Child options. In scalar context (API available since 1.897), call Cfinish> automatically upon leaving the scope or program. my $guard = MCE::Child->init( max_workers => 'auto', # default undef, unlimited # Specify a percentage. MCE::Child 1.876+. max_workers => '25%', # 4 on HW with 16 lcores max_workers => '50%', # 8 on HW with 16 lcores child_timeout => 20, # default undef, no timeout posix_exit => 1, # default undef, CORE::exit void_context => 1, # default undef on_start => sub { my ( $pid, $ident ) = @_; ... }, on_finish => sub { my ( $pid, $exit, $ident, $signal, $error, @ret ) = @_; ... } ); # Identification given as an option or the 1st argument. for my $key ( 'aa' .. 'zz' ) { MCE::Child->create( { ident => $key }, sub { ... } ); MCE::Child->create( $key, sub { ... } ); } MCE::Child->wait_all; Set C if you want to limit the number of workers by waiting automatically for an available slot. Specify a percentage or C to obtain the number of logical cores via C. Set C, in number of seconds, if you want the child process to terminate after some time. The default is C<0> for no timeout. Set C to avoid all END and destructor processing. Constructing MCE::Child inside a thread implies 1 or if present CGI, FCGI, Coro, Curses, Gearman::Util, Gearman::XS, LWP::UserAgent, Mojo::IOLoop, STFL, Tk, Wx, or Win32::GUI. Set C to create the child process in void context for the return value. Otherwise, the return context is wantarray-aware for C and C and determined when retrieving the data. The callback options C and C are called in the parent process after starting the worker and later when terminated. The arguments for the subroutines were inspired by L. The parameters for C are the following: - pid of the child process - identification (ident option or 1st arg to create) The parameters for C are the following: - pid of the child process - program exit code - identification (ident option or 1st arg to create) - exit signal id - error message from eval inside MCE::Child - returned data =item $child->is_running() Returns true if a child is still running. =item $child->is_joinable() Returns true if the child has finished running and not yet joined. =item $child->kill( 'SIG...' ) Sends the specified signal to the child. Returns the child object to allow for method chaining. As with C, it is important to join eventually if not immediately to not leave a zombie or defunct process. $child->kill('SIG...')->join(); The following is a parallel demonstration comparing C against C and C on a Fedora 23 VM. Joining begins after all workers have been notified to quit. use Time::HiRes qw(time); use Redis; use Redis::Fast; use MCE::Child; use MCE::Shared; my $redis = Redis->new(); my $rfast = Redis::Fast->new(); my $array = MCE::Shared->array(); sub parallel_redis { my ($_redis) = @_; my ($count, $quit, $len) = (0, 0); # instead, use a flag to exit loop $SIG{'QUIT'} = sub { $quit = 1 }; while () { $len = $_redis->rpush('list', $count++); last if $quit; } $count; } sub parallel_array { my ($count, $quit, $len) = (0, 0); # do not exit from inside handler $SIG{'QUIT'} = sub { $quit = 1 }; while () { $len = $array->push($count++); last if $quit; } $count; } sub benchmark_this { my ($desc, $num_procs, $timeout, $code, @args) = @_; my ($start, $total) = (time(), 0); MCE::Child->new($code, @args) for 1..$num_procs; sleep $timeout; # joining is not immediate; ok $_->kill('QUIT') for MCE::Child->list(); # joining later; ok $total += $_->join() for MCE::Child->list(); printf "$desc <> duration: %0.03f secs, count: $total\n", time() - $start; sleep 0.2; } benchmark_this('Redis ', 8, 5.0, \¶llel_redis, $redis); benchmark_this('Redis::Fast', 8, 5.0, \¶llel_redis, $rfast); benchmark_this('MCE::Shared', 8, 5.0, \¶llel_array); =item MCE::Child->list() Returns a list of all child objects not yet joined. @procs = MCE::Child->list(); =item MCE::Child->list_pids() Returns a list of all child pids not yet joined (available since 1.849). @pids = MCE::Child->list_pids(); $SIG{INT} = $SIG{HUP} = $SIG{TERM} = sub { # Signal workers all at once CORE::kill('KILL', MCE::Child->list_pids()); exec('reset'); }; =item MCE::Child->list_running() Returns a list of all child objects that are still running. @procs = MCE::Child->list_running(); =item MCE::Child->list_joinable() Returns a list of all child objects that have completed running. Thus, ready to be joined without blocking. @procs = MCE::Child->list_joinable(); =item MCE::Child->max_workers([ N ]) Getter and setter for max_workers. Specify a number or 'auto' to acquire the total number of cores via MCE::Util::get_ncpu. Specify a false value to set back to no limit. =item MCE::Child->pending() Returns a count of all child objects not yet joined. $count = MCE::Child->pending(); =item $child->result() Returns the result obtained by C, C, or C. If the process has not yet exited, waits for the corresponding child to complete its execution. use MCE::Child; use Time::HiRes qw(sleep); sub task { my ($id) = @_; sleep $id * 0.333; return $id; } MCE::Child->create('task', $_) for ( reverse 1 .. 3 ); # 1 while MCE::Child->wait_one(); while ( my $child = MCE::Child->wait_one() ) { my $err = $child->error() || 'no error'; my $res = $child->result(); my $pid = $child->pid(); print "[$pid] $err : $res\n"; } Like C described above, the context (void, scalar or list) for the return value(s) is determined at the time C is called and mostly C aware. my $child1 = MCE::Child->create( sub { my @res = qw(foo bar baz); return (@res); }); my @res1 = $child1->result(); # ( foo, bar, baz ) my $res1 = $child1->result(); # baz my $child2 = MCE::Child->create( sub { return 'foo'; }); my @res2 = $child2->result(); # ( foo ) my $res2 = $child2->result(); # foo =item MCE::Child->seed() Class method that returns the internal random generated seed or undefined. The seed is generated once during init or initial create. Current API available since 1.895. =item MCE::Child->self() Class method that allows a child to obtain it's own I object. =item $child->pid() =item $child->tid() Returns the ID of the child. pid: $$ process id tid: $$ alias for pid =item MCE::Child->pid() =item MCE::Child->tid() Class methods that allows a child to obtain its own ID. pid: $$ process id tid: $$ alias for pid =item MCE::Child->wait_one() =item MCE::Child->waitone() =item MCE::Child->wait_all() =item MCE::Child->waitall() Meaningful for the manager process only, waits for one or all child processes to complete execution. Afterwards, returns the corresponding child objects. If a child doesn't exist, returns the C value or an empty list for C and C respectively. The C and C methods are aliases for compatibility with C. use MCE::Child; use Time::HiRes qw(sleep); sub task { my $id = shift; sleep $id * 0.333; return $id; } MCE::Child->create('task', $_) for ( reverse 1 .. 3 ); # join, traditional use case $_->join() for MCE::Child->list(); # wait_one, simplistic use case 1 while MCE::Child->wait_one(); # wait_one while ( my $child = MCE::Child->wait_one() ) { my $err = $child->error() || 'no error'; my $res = $child->result(); my $pid = $child->pid(); print "[$pid] $err : $res\n"; } # wait_all my @procs = MCE::Child->wait_all(); for ( @procs ) { my $err = $_->error() || 'no error'; my $res = $_->result(); my $pid = $_->pid(); print "[$pid] $err : $res\n"; } =item MCE::Child->yield( [ floating_seconds ] ) Give other workers a chance to run, optionally for given time. Yield behaves similarly to MCE's interval option. It throttles workers from running too fast. A demonstration is provided in the next section for fetching URLs in parallel. The default C is 0.008 and 0.015 on UNIX and Windows, respectively. Pass 0 if simply wanting to give other workers a chance to run. # total run time: 1.00 second MCE::Child->create( sub { MCE::Child->yield(0.25) } ) for 1 .. 4; MCE::Child->wait_all(); =back =head1 THREADS-like DETACH CAPABILITY Threads-like detach capability was added starting with the 1.867 release. A threads example is shown first followed by the MCE::Child example. All one needs to do is set the CHLD signal handler to IGNORE. Unfortunately, this works on UNIX platforms only. The child process restores the CHLD handler to default, so is able to deeply spin workers and reap if desired. use threads; for ( 1 .. 8 ) { async { # do something }->detach; } use MCE::Child; # Have the OS reap workers automatically when exiting. # The on_finish option is ignored if specified (no-op). # Ensure not inside a thread on UNIX platforms. $SIG{CHLD} = 'IGNORE'; for ( 1 .. 8 ) { mce_child { # do something }; } # Optionally, wait for any remaining workers before leaving. # This is necessary if workers are consuming shared objects, # constructed via MCE::Shared. MCE::Child->wait_all; The following is another way and works on Windows. Here, the on_finish handler works as usual. use MCE::Child; MCE::Child->init( on_finish = sub { ... }, ); for ( 1 .. 8 ) { $_->join for MCE::Child->list_joinable; mce_child { # do something }; } MCE::Child->wait_all; =head1 PARALLEL::FORKMANAGER-like DEMONSTRATION MCE::Child behaves similarly to threads for the most part. It also provides L-like capabilities. The C example is shown first followed by a version using C. =over 3 =item Parallel::ForkManager use strict; use warnings; use Parallel::ForkManager; use Time::HiRes 'time'; my $start = time; my $pm = Parallel::ForkManager->new(10); $pm->set_waitpid_blocking_sleep(0); $pm->run_on_finish( sub { my ($pid, $exit_code, $ident, $exit_signal, $core_dumped, $resp) = @_; print "child $pid completed: $ident => ", $resp->[0], "\n"; }); DATA_LOOP: foreach my $data ( 1..2000 ) { # forks and returns the pid for the child my $pid = $pm->start($data) and next DATA_LOOP; my $ret = [ $data * 2 ]; $pm->finish(0, $ret); } $pm->wait_all_children; printf STDERR "duration: %0.03f seconds\n", time - $start; =item MCE::Child use strict; use warnings; use MCE::Child 1.843; use Time::HiRes 'time'; my $start = time; MCE::Child->init( max_workers => 10, on_finish => sub { my ($pid, $exit_code, $ident, $exit_signal, $error, $resp) = @_; print "child $pid completed: $ident => ", $resp->[0], "\n"; } ); foreach my $data ( 1..2000 ) { MCE::Child->create( $data, sub { [ $data * 2 ]; }); } MCE::Child->wait_all; printf STDERR "duration: %0.03f seconds\n", time - $start; =item Time to spin 2,000 workers and obtain results (in seconds). Results were obtained on a Macbook Pro (2.6 GHz ~ 3.6 GHz with Turbo Boost). Parallel::ForkManager 2.02 uses Moo. Therefore, I ran again with Moo loaded at the top of the script. MCE::Hobo uses MCE::Shared to retrieve data during reaping. MCE::Child uses MCE::Channel, no shared-manager. Version Cygwin Windows Linux macOS FreeBSD MCE::Child 1.843 19.099s 17.091s 0.965s 1.534s 1.229s MCE::Hobo 1.843 20.514s 19.594s 1.246s 1.629s 1.613s P::FM 1.20 19.703s 19.235s 0.875s 1.445s 1.346s MCE::Child 1.843 20.426s 18.417s 1.116s 1.632s 1.338s Moo loaded MCE::Hobo 1.843 21.809s 20.810s 1.407s 1.759s 1.722s Moo loaded P::FM 2.02 21.668s 25.927s 1.882s 2.612s 2.483s Moo used =item Set posix_exit to avoid all END and destructor processing. This is helpful for reducing overhead when workers exit. Ditto if using a Perl module not parallel safe. The option is ignored on Windows C<$^O eq 'MSWin32'>. MCE::Child->init( posix_exit => 1, ... ); MCE::Hobo->init( posix_exit => 1, ... ); Version Cygwin Windows Linux macOS FreeBSD MCE::Child 1.843 19.815s ignored 0.824s 1.284s 1.245s Moo loaded MCE::Hobo 1.843 21.029s ignored 0.953s 1.335s 1.439s Moo loaded =back =head1 PARALLEL HTTP GET DEMONSTRATION USING ANYEVENT This demonstration constructs two queues, two handles, starts the shared-manager process if needed, and spawns four workers. For this demonstration, am chunking 64 URLs per job. In reality, one may run with 200 workers and chunk 300 URLs on a 24-way box. # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # perl demo.pl -- all output # perl demo.pl >/dev/null -- mngr/child output # perl demo.pl 2>/dev/null -- show results only # # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ use strict; use warnings; use AnyEvent; use AnyEvent::HTTP; use Time::HiRes qw( time ); use MCE::Child; use MCE::Shared; # Construct two queues, input and return. my $que = MCE::Shared->queue(); my $ret = MCE::Shared->queue(); # Construct shared handles for serializing output from many workers # writing simultaneously. This prevents garbled output. mce_open my $OUT, ">>", \*STDOUT or die "open error: $!"; mce_open my $ERR, ">>", \*STDERR or die "open error: $!"; # Spawn workers early for minimum memory consumption. MCE::Child->create({ posix_exit => 1 }, 'task', $_) for 1 .. 4; # Obtain or generate input data for workers to process. my ( $count, @urls ) = ( 0 ); push @urls, map { "http://127.0.0.$_/" } 1..254; push @urls, map { "http://192.168.0.$_/" } 1..254; # 508 URLs total while ( @urls ) { my @chunk = splice(@urls, 0, 64); $que->enqueue( { ID => ++$count, INPUT => \@chunk } ); } # So that workers leave the loop after consuming the queue. $que->end(); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Loop for the manager process. The manager may do other work if # need be and periodically check $ret->pending() not shown here. # # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $start = time; printf {$ERR} "Mngr - entering loop\n"; while ( $count ) { my ( $result, $failed ) = $ret->dequeue( 2 ); # Remove ID from result, so not treated as a URL item. printf {$ERR} "Mngr - received job %s\n", delete $result->{ID}; # Display the URL and the size captured. foreach my $url ( keys %{ $result } ) { printf {$OUT} "%s: %d\n", $url, length($result->{$url}) if $result->{$url}; # url has content } # Display URLs could not reach. if ( @{ $failed } ) { foreach my $url ( @{ $failed } ) { print {$OUT} "Failed: $url\n"; } } # Decrement the count. $count--; } MCE::Child->wait_all(); printf {$ERR} "Mngr - exiting loop\n\n"; printf {$ERR} "Duration: %0.3f seconds\n\n", time - $start; exit; # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Child processes enqueue two items ( $result and $failed ) per each # job for the manager process. Likewise, the manager process dequeues # two items above. Optionally, child processes may include the ID in # the result. # # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub task { my ( $id ) = @_; printf {$ERR} "Child $id entering loop\n"; while ( my $job = $que->dequeue() ) { my ( $result, $failed ) = ( { ID => $job->{ID} }, [ ] ); # Walk URLs, provide a hash and array refs for data. printf {$ERR} "Child $id running job $job->{ID}\n"; walk( $job, $result, $failed ); # Send results to the manager process. $ret->enqueue( $result, $failed ); } printf {$ERR} "Child $id exiting loop\n"; } sub walk { my ( $job, $result, $failed ) = @_; # Yielding is critical when running an event loop in parallel. # Not doing so means that the app may reach contention points # with the firewall and likely impose unnecessary hardship at # the OS level. The idea here is not to have multiple workers # initiate HTTP requests to a batch of URLs at the same time. # Yielding behaves similarly like scatter to have the child # process run solo for a fraction of time. MCE::Child->yield( 0.03 ); my $cv = AnyEvent->condvar(); # Populate the hash ref for the URLs it could reach. # Do not mix AnyEvent timeout with child timeout. # Therefore, choose event timeout when available. foreach my $url ( @{ $job->{INPUT} } ) { $cv->begin(); http_get $url, timeout => 2, sub { my ( $data, $headers ) = @_; $result->{$url} = $data; $cv->end(); }; } $cv->recv(); # Populate the array ref for URLs it could not reach. foreach my $url ( @{ $job->{INPUT} } ) { push @{ $failed }, $url unless (exists $result->{ $url }); } return; } __END__ $ perl demo.pl Child 1 entering loop Child 2 entering loop Child 3 entering loop Mngr - entering loop Child 2 running job 2 Child 3 running job 3 Child 1 running job 1 Child 4 entering loop Child 4 running job 4 Child 2 running job 5 Mngr - received job 2 Child 3 running job 6 Mngr - received job 3 Child 1 running job 7 Mngr - received job 1 Child 4 running job 8 Mngr - received job 4 http://192.168.0.1/: 3729 Child 2 exiting loop Mngr - received job 5 Child 3 exiting loop Mngr - received job 6 Child 1 exiting loop Mngr - received job 7 Child 4 exiting loop Mngr - received job 8 Mngr - exiting loop Duration: 4.131 seconds =head1 CROSS-PLATFORM TEMPLATE FOR BINARY EXECUTABLE Making an executable is possible with the L module. On the Windows platform, threads, threads::shared, and exiting via threads are necessary for the binary to exit successfully. # https://metacpan.org/pod/PAR::Packer # https://metacpan.org/pod/pp # # pp -o demo.exe demo.pl # ./demo.exe use strict; use warnings; use if $^O eq "MSWin32", "threads"; use if $^O eq "MSWin32", "threads::shared"; # Include minimum dependencies for MCE::Child. # Add other modules required by your application here. use Storable (); use Time::HiRes (); # use IO::FDPass (); # optional: for condvar, handle, queue # use Sereal (); # optional: for faster serialization use MCE::Child; use MCE::Shared; # For PAR to work on the Windows platform, one must include manually # any shared modules used by the application. # use MCE::Shared::Array; # if using MCE::Shared->array # use MCE::Shared::Cache; # if using MCE::Shared->cache # use MCE::Shared::Condvar; # if using MCE::Shared->condvar # use MCE::Shared::Handle; # if using MCE::Shared->handle, mce_open # use MCE::Shared::Hash; # if using MCE::Shared->hash # use MCE::Shared::Minidb; # if using MCE::Shared->minidb # use MCE::Shared::Ordhash; # if using MCE::Shared->ordhash # use MCE::Shared::Queue; # if using MCE::Shared->queue # use MCE::Shared::Scalar; # if using MCE::Shared->scalar # Et cetera. Only load modules needed for your application. use MCE::Shared::Sequence; # if using MCE::Shared->sequence my $seq = MCE::Shared->sequence( 1, 9 ); sub task { my ( $id ) = @_; while ( defined ( my $num = $seq->next() ) ) { print "$id: $num\n"; sleep 1; } } sub main { MCE::Child->new( \&task, $_ ) for 1 .. 3; MCE::Child->wait_all(); } # Main must run inside a thread on the Windows platform or workers # will fail duing exiting, causing the exe to crash. The reason is # that PAR or a dependency isn't multi-process safe. ( $^O eq "MSWin32" ) ? threads->create(\&main)->join() : main(); threads->exit(0) if $INC{"threads.pm"}; =head1 LIMITATION MCE::Child emits an error when C, C, and C isn't called by the managed process, where the child was spawned. This is a limitation in MCE::Child only due to not involving a shared-manager process for IPC. This use-case is not typical. =head1 CREDITS The inspiration for C comes from wanting C-like behavior for processes compatible with Perl 5.8. Both can run side-by-side including safe-use by MCE workers. Likewise, the documentation resembles C. The inspiration for C and C comes from the C module. =head1 SEE ALSO =over 3 =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =back =head1 INDEX L, L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Loop.pm000644 000765 000024 00000063153 14735610752 015045 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## MCE model for building parallel loops. ## ############################################################################### package MCE::Loop; use strict; use warnings; no warnings qw( threads recursion uninitialized ); our $VERSION = '1.901'; ## 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 $_tid = $INC{'threads.pm'} ? threads->tid() : 0; sub CLONE { $_tid = threads->tid() if $INC{'threads.pm'}; } ############################################################################### ## ---------------------------------------------------------------------------- ## 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. if ($_pkg !~ /^MCE::/) { 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' ); $_p->{INIT_RELAY} = shift, next if ( $_arg eq 'init_relay' ); $_p->{USE_THREADS} = shift, next if ( $_arg eq 'use_threads' ); ## Sereal 3.015+, if available, is used automatically by MCE 1.8+. 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::_parse_max_workers($_p->{MAX_WORKERS}); MCE::_validate_number($_p->{MAX_WORKERS}, 'MAX_WORKERS', $_tag); MCE::_validate_number($_p->{CHUNK_SIZE}, 'CHUNK_SIZE', $_tag) unless ($_p->{CHUNK_SIZE} eq 'auto'); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Init and finish routines. ## ############################################################################### sub MCE::Loop::_guard::DESTROY { my ($_pkg, $_id) = @{ $_[0] }; if (defined $_pkg && $_id eq "$$.$_tid") { @{ $_[0] } = (); MCE::Loop->finish($_pkg); } return; } sub init (@) { shift if (defined $_[0] && $_[0] eq 'MCE::Loop'); my $_pkg = "$$.$_tid.".caller(); $_params->{$_pkg} = (ref $_[0] eq 'HASH') ? shift : { @_ }; @_ = (); defined wantarray ? bless([$_pkg, "$$.$_tid"], MCE::Loop::_guard::) : (); } 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') { if (@{ $_[0] } > 3 && $_[0]->[3] =~ /\d$/) { $_begin = $_[0]->[0], $_end = $_[0]->[-1]; $_params->{$_pid}{sequence} = [ $_[0]->[0], $_[0]->[-1] ]; } else { $_begin = $_[0]->[0], $_end = $_[0]->[1]; $_params->{$_pid}{sequence} = $_[0]; } } elsif (ref $_[0] eq '' || ref($_[0]) =~ /^Math::/) { if (@_ > 3 && $_[3] =~ /\d$/) { $_begin = $_[0], $_end = $_[-1]; $_params->{$_pid}{sequence} = [ $_[0], $_[-1] ]; } else { $_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} = undef; @_ = (); 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 (@_ == 1 && $_r =~ /^(?:ARRAY|HASH|SCALAR|CODE|GLOB|FileHandle|IO::)/) { $_input_data = shift; } if (defined (my $_p = $_params->{$_pid})) { $_max_workers = MCE::_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::_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($_MCE->{$_pid}); 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("$_tag: ($_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 init_relay use_threads /) { $_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; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Loop - MCE model for building parallel loops =head1 VERSION This document describes MCE::Loop version 1.901 =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($_) } \@list; ## Important; pass an array_ref for deeply input data mce_loop { do_work($_) } [ [ 0, 1 ], [ 0, 2 ], ... ]; mce_loop { do_work($_) } \@deeply_list; ## File path, glob ref, IO::All::{ File, Pipe, STDIO } obj, or scalar ref ## Workers read directly and not involve the manager process mce_loop_f { chomp; do_work($_) } "/path/to/file"; # efficient ## Involves the manager process, therefore slower mce_loop_f { chomp; do_work($_) } $file_handle; mce_loop_f { chomp; do_work($_) } $io; 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. ## Array or array_ref mce_loop { do_work($_) for (@{ $_ }) } 1..10000; mce_loop { do_work($_) for (@{ $_ }) } \@list; ## Important; pass an array_ref for deeply input data mce_loop { do_work($_) for (@{ $_ }) } [ [ 0, 1 ], [ 0, 2 ], ... ]; mce_loop { do_work($_) for (@{ $_ }) } \@deeply_list; ## Resembles code using the core MCE 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 init_relay => 0, # Default undef; MCE 1.882+ use_threads => 0, # Default undef; MCE 1.882+ ; From MCE 1.8 onwards, Sereal 3.015+ is loaded automatically if available. Specify C<< Sereal => 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 } =back The init function accepts a hash of MCE options. In scalar context (API available since 1.897), call Cfinish> automatically upon leaving the scope or program. use MCE::Loop; my $guard = 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 =head1 API DOCUMENTATION The following assumes chunk_size equals 1 in order to demonstrate all the possibilities for providing input data. =over 3 =item MCE::Loop->run ( sub { code }, list ) =item mce_loop { code } list =back Input data may be defined using a list, an array ref, or a hash ref. # $_ contains the item when chunk_size => 1 mce_loop { do_work($_) } 1..1000; mce_loop { do_work($_) } \@list; # Important; pass an array_ref for deeply input data mce_loop { do_work($_) } [ [ 0, 1 ], [ 0, 2 ], ... ]; mce_loop { do_work($_) } \@deeply_list; # Chunking; any chunk_size => 1 or greater my %res = mce_loop { my ($mce, $chunk_ref, $chunk_id) = @_; my %ret; for my $item (@{ $chunk_ref }) { $ret{$item} = $item * 2; } MCE->gather(%ret); } \@list; # Input hash; current API available since 1.828 my %res = mce_loop { my ($mce, $chunk_ref, $chunk_id) = @_; my %ret; for my $key (keys %{ $chunk_ref }) { $ret{$key} = $chunk_ref->{$key} * 2; } MCE->gather(%ret); } \%hash; =over 3 =item MCE::Loop->run_file ( sub { code }, file ) =item mce_loop_f { code } file =back The fastest of these is the /path/to/file. Workers communicate the next offset position among themselves with zero interaction by the manager process. C { File, Pipe, STDIO } is supported since MCE 1.845. # $_ contains the line when chunk_size => 1 mce_loop_f { $_ } "/path/to/file"; # faster mce_loop_f { $_ } $file_handle; mce_loop_f { $_ } $io; # IO::All mce_loop_f { $_ } \$scalar; # chunking, any chunk_size => 1 or greater my %res = mce_loop_f { my ($mce, $chunk_ref, $chunk_id) = @_; my $buf = ''; for my $line (@{ $chunk_ref }) { $buf .= $line; } MCE->gather($chunk_id, $buf); } "/path/to/file"; =over 3 =item MCE::Loop->run_seq ( sub { code }, $beg, $end [, $step, $fmt ] ) =item mce_loop_s { code } $beg, $end [, $step, $fmt ] =back Sequence may 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"); # $_ contains the sequence number when chunk_size => 1 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 }; # chunking, any chunk_size => 1 or greater my %res = mce_loop_s { my ($mce, $chunk_ref, $chunk_id) = @_; my $buf = ''; for my $seq (@{ $chunk_ref }) { $buf .= "$seq\n"; } MCE->gather($chunk_id, $buf); } [ $beg, $end ]; 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 ); # Typically, the input scalar $_ contains the sequence number # when chunk_size => 1, unless the bounds_only option is set # which is the case here. Thus, $_ points to $chunk_ref. mce_loop_s { my ($mce, $chunk_ref, $chunk_id) = @_; # $chunk_ref contains 2 items, not 1_250_000 # my ( $begin, $end ) = ( $_->[0], $_->[1] ); my $begin = $chunk_ref->[0]; my $end = $chunk_ref->[1]; # for my $seq ( $begin .. $end ) { # ... # } 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 =over 3 =item MCE::Loop->run ( sub { code }, iterator ) =item mce_loop { code } iterator =back An iterator reference may be specified for input_data. Iterators are described under section "SYNTAX for INPUT_DATA" at L. mce_loop { $_ } make_iterator(10, 30, 2); =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 @a1 = mce_loop { MCE->gather($_ * 2) } 1..100; print "@a1\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 may 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 =back 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; =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Candy.pm000644 000765 000024 00000036334 14735610752 015173 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## Sugar methods and output iterators. ## ############################################################################### package MCE::Candy; use strict; use warnings; no warnings qw( threads recursion uninitialized ); our $VERSION = '1.901'; our @CARP_NOT = qw( MCE ); ############################################################################### ## ---------------------------------------------------------------------------- ## Import routine. ## ############################################################################### my $_imported; sub import { return if ($_imported++); unless ($INC{'MCE.pm'}) { $\ = 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: (HASH) not allowed as input by this method') if (ref $_input_data eq 'HASH'); 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; if (ref $_aref eq 'MCE::Shared::Object') { my $_pkg = $_aref->blessed; MCE::_croak('The argument to (out_iter_array) is not valid.') unless $_pkg->can('TIEARRAY'); } else { 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_callback { my $_cref = shift; my %_tmp; my $_order_id = 1; MCE::_croak('The argument to (out_iter_callback) is not a CODE ref.') unless (ref $_cref eq 'CODE'); return sub { my $_chunk_id = shift; if ($_chunk_id == $_order_id && keys %_tmp == 0) { ## already orderly $_order_id++, $_cref->(@_); } else { ## hold temporarily otherwise until orderly @{ $_tmp{ $_chunk_id } } = @_; while (1) { last unless exists $_tmp{ $_order_id }; $_cref->(@{ 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::)/); if ($_fh->can('print')) { return sub { my $_chunk_id = shift; if ($_chunk_id == $_order_id && keys %_tmp == 0) { ## already orderly $_order_id++, $_fh->print(@_); } else { ## hold temporarily otherwise until orderly @{ $_tmp{ $_chunk_id } } = @_; while (1) { last unless exists $_tmp{ $_order_id }; $_fh->print(@{ delete $_tmp{ $_order_id++ } }); } } }; } else { 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.901 =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( max_workers => $max_workers, chunk_size => 20 ); ## Arguments inside the code block are the same as passed to user_func. $mce->forchunk(\@input_array, sub { my ($mce, $chunk_ref, $chunk_id) = @_; foreach ( @{ $chunk_ref } ) { MCE->print("$chunk_id: $_\n"); } }); ## Input hash, current API available since 1.828. $mce->forchunk(\%input_hash, sub { my ($mce, $chunk_ref, $chunk_id) = @_; for my $key ( keys %{ $chunk_ref } ) { MCE->print("$chunk_id: [ $key ] ", $chunk_ref->{$key}, "\n"); } }); ## Passing chunk_size as an option. $mce->forchunk(\@input_array, { chunk_size => 30 }, sub { ... }); $mce->forchunk(\%input_hash, { 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. Unlike forchunk above, a hash reference as input data isn't allowed. 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 may 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 provides three output iterators useful for preserving output order while gathering data. The chunk_id value must be the first argument to gather. Gather must be called once and not more 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 ]); $mce->shutdown(); 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 ]); $mce->shutdown(); print scalar @results, "\n"; -- Output 100000 =head2 gather => MCE::Candy::out_iter_callback( \&cb_func ) MCE workers pass arguments for the callback function. The chunk_id argument to gather is used internally for calling the callback function orderly. Current API available since 1.897. use MCE; use MCE::Candy; my @results; my $max_status = 0; sub upd_vars { push @results, @{ $_[0] }; $max_status = $_[1] if ($_[1] > $max_status); } my $mce = MCE->new( chunk_size => 100, max_workers => 4, gather => MCE::Candy::out_iter_callback(\&upd_vars), user_func => sub { my ($mce, $chunk_ref, $chunk_id) = @_; my @output; foreach my $item (@{ $chunk_ref }) { push @output, $item * 2; } my $status = $mce->chunk_id == 3 ? 2 : 0; $mce->gather($chunk_id, [ @output ], $status); } ); $mce->process([ 100_000 .. 200_000 - 1 ]); $mce->shutdown(); print scalar @results, "\n"; print $max_status, "\n"; -- Output 100000 2 =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 =head2 gather => MCE::Candy::out_iter_fh( $io ) Same thing, an C object that can C is supported since MCE 1.845. use IO::All; use MCE::Flow; use MCE::Candy; my $io = io('/tmp/foo.txt'); # i.e. $io->can('print') mce_flow { chunk_size => 1, max_workers => 4, gather => MCE::Candy::out_iter_fh($io) }, sub { my ($mce, $chunk_ref, $chunk_id) = @_; $mce->gather($chunk_id, $chunk_ref->[0] * 2, "\n"); }, (100 .. 109); $io->close; -- 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. The 'chunk_id' argument to gather is still needed and set uniquely, same as 'wid' when not processing input data. =head2 gather => MCE::Candy::out_iter_array( \@array ) =head2 gather => MCE::Candy::out_iter_callback( \&cb_func ) use MCE::Flow; use MCE::Candy; my @results; sub append_results { push @results, $_[0]; } mce_flow { max_workers => 'auto', ## Note that 'auto' is never greater than 8 gather => MCE::Candy::out_iter_array(\@results), # gather => MCE::Candy::out_iter_callback(\&append_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->wid, { 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.901/lib/MCE/Mutex/000755 000765 000024 00000000000 14735611252 014664 5ustar00mariostaff000000 000000 MCE-1.901/lib/MCE/Mutex.pm000644 000765 000024 00000012655 14735610752 015237 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## Locking for Many-Core Engine. ## ############################################################################### package MCE::Mutex; use strict; use warnings; no warnings qw( threads recursion uninitialized ); our $VERSION = '1.901'; ## no critic (BuiltinFunctions::ProhibitStringyEval) ## no critic (TestingAndDebugging::ProhibitNoStrict) use Carp (); ## global Mutex used by MCE, MCE::Child, and MCE::Hobo inside threads ## on UNIX platforms if ( $INC{'threads.pm'} && $^O !~ /mswin|mingw|msys|cygwin/i ) { $MCE::_GMUTEX = MCE::Mutex->new( impl => 'Channel' ); MCE::Mutex::Channel::_save_for_global_cleanup($MCE::_GMUTEX); } sub new { my ($class, %argv) = @_; my $impl = defined($argv{impl}) ? $argv{impl} : defined($argv{path}) ? 'Flock' : 'Channel'; $impl = ucfirst( lc $impl ); eval "require MCE::Mutex::$impl; 1;" || Carp::croak("Could not load Mutex implementation '$impl': $@"); my $pkg = 'MCE::Mutex::'.$impl; no strict 'refs'; return $pkg->new( %argv ); } ## base class method sub impl { return $_[0]->{impl} || 'Not defined'; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Mutex - Locking for Many-Core Engine =head1 VERSION This document describes MCE::Mutex version 1.901 =head1 SYNOPSIS use MCE::Mutex; my $mutex = MCE::Mutex->new; { use MCE::Flow max_workers => 4; mce_flow sub { $mutex->lock; # access shared resource my $wid = MCE->wid; MCE->say($wid); sleep 1; $mutex->unlock; }; } { use MCE::Hobo; MCE::Hobo->create('work', $_) for 1..4; MCE::Hobo->waitall; } { use threads; threads->create('work', $_) for 5..8; $_->join for ( threads->list ); } sub work { my ($id) = @_; $mutex->lock; # access shared resource print $id, "\n"; sleep 1; $mutex->unlock; } =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 ( ) =head2 MCE::Mutex->new ( impl => "Channel" ) =head2 MCE::Mutex->new ( impl => "Flock", [ path => "/tmp/file.lock" ] ) =head2 MCE::Mutex->new ( path => "/tmp/file.lock" ) Creates a new mutex. Channel locking (the default), unless C is given, is through a pipe or socket depending on the platform. The advantage of channel locking is not having to re-establish handles inside new processes and threads. For Fcntl-based locking, it is the responsibility of the caller to remove the C, associated with the mutex, when path is given. Otherwise, it establishes a C internally including removal on scope exit. =head2 $mutex->impl ( void ) Returns the implementation used for the mutex. $m1 = MCE::Mutex->new( ); $m1->impl(); # Channel $m2 = MCE::Mutex->new( path => /tmp/my.lock ); $m2->impl(); # Flock $m3 = MCE::Mutex->new( impl => "Channel" ); $m3->impl(); # Channel $m4 = MCE::Mutex->new( impl => "Flock" ); $m4->impl(); # Flock Current API available since 1.822. =head2 $mutex->lock ( void ) =head2 $mutex->lock_exclusive ( void ) Attempts to grab an exclusive 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. The method C is an alias for C, available since 1.822. ( my $mutex = MCE::Mutex->new( path => $0 ) )->lock_exclusive; =head2 $mutex->lock_shared ( void ) Like C, but attempts to grab a shared lock instead. The C method is an alias to C otherwise for non-Fcntl implementations. Current API available since 1.822. =head2 $guard = $mutex->guard_lock ( void ) This method calls C and returns a guard object. When the guard object is destroyed, it automatically calls C. Current API available since 1.889. =head2 $mutex->unlock ( void ) Releases the lock. A held lock by an exiting process or thread is released automatically. =head2 $mutex->synchronize ( sub { ... }, @_ ) =head2 $mutex->enter ( sub { ... }, @_ ) Obtains a lock, runs the code block, and releases the lock after the block completes. Optionally, the method is C aware. my $val = $mutex->synchronize( sub { # access shared resource return 'scalar'; }); my @ret = $mutex->enter( sub { # access shared resource return @list; }); The method C is an alias for C, available since 1.822. =head2 $mutex->timedwait ( floating_seconds ) Blocks until obtaining an exclusive lock. A false value is returned if the timeout is reached, and a true value otherwise. The default is 1 second. my $mutex = MCE::Mutex->new( path => $0 ); # terminate script if a previous instance is still running exit unless $mutex->timedwait( 2 ); ... Current API available since 1.822. =head1 INDEX L, L =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Mutex/Channel.pm000644 000765 000024 00000012743 14735610752 016605 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## MCE::Mutex::Channel - Mutex locking via a pipe or socket. ## ############################################################################### package MCE::Mutex::Channel; use strict; use warnings; no warnings qw( threads recursion uninitialized once ); our $VERSION = '1.901'; use if $^O eq 'MSWin32', 'threads'; use if $^O eq 'MSWin32', 'threads::shared'; use base 'MCE::Mutex'; use MCE::Util (); use Scalar::Util qw(looks_like_number weaken); use Time::HiRes 'alarm'; my $is_MSWin32 = ($^O eq 'MSWin32') ? 1 : 0; my $use_pipe = ($^O !~ /mswin|mingw|msys|cygwin/i && $] gt '5.010000'); my $tid = $INC{'threads.pm'} ? threads->tid : 0; sub CLONE { $tid = threads->tid if $INC{'threads.pm'}; } sub MCE::Mutex::Channel::_guard::DESTROY { my ($pid, $obj) = @{ $_[0] }; CORE::syswrite($obj->{_w_sock}, '0'), $obj->{ $pid } = 0 if $obj->{ $pid }; return; } sub DESTROY { my ($pid, $obj) = ($tid ? $$ .'.'. $tid : $$, @_); CORE::syswrite($obj->{_w_sock}, '0'), $obj->{$pid } = 0 if $obj->{$pid }; CORE::syswrite($obj->{_r_sock}, '0'), $obj->{$pid.'b'} = 0 if $obj->{$pid.'b'}; if ( $obj->{_init_pid} eq $pid ) { (!$use_pipe || $obj->{impl} eq 'Channel2') ? MCE::Util::_destroy_socks($obj, qw(_w_sock _r_sock)) : MCE::Util::_destroy_pipes($obj, qw(_w_sock _r_sock)); } return; } my @mutex; sub _destroy { my $pid = $tid ? $$ .'.'. $tid : $$; # Called by { MCE, MCE::Child, and MCE::Hobo }::_exit for my $i ( 0 .. @mutex - 1 ) { CORE::syswrite($mutex[$i]->{_w_sock}, '0'), $mutex[$i]->{$pid} = 0 if ( $mutex[$i]->{$pid} ); CORE::syswrite($mutex[$i]->{_r_sock}, '0'), $mutex[$i]->{$pid.'b'} = 0 if ( $mutex[$i]->{$pid.'b'} ); } } sub _save_for_global_cleanup { push(@mutex, $_[0]), weaken($mutex[-1]); } ############################################################################### ## ---------------------------------------------------------------------------- ## Public methods. ## ############################################################################### sub new { my ($class, %obj) = (@_, impl => 'Channel'); $obj{_init_pid} = $tid ? $$ .'.'. $tid : $$; $obj{_t_lock} = threads::shared::share( my $t_lock ) if $is_MSWin32; $use_pipe ? MCE::Util::_pipe_pair(\%obj, qw(_r_sock _w_sock)) : MCE::Util::_sock_pair(\%obj, qw(_r_sock _w_sock)); CORE::syswrite($obj{_w_sock}, '0'); bless \%obj, $class; if ( caller !~ /^MCE:?/ || caller(1) !~ /^MCE:?/ ) { MCE::Mutex::Channel::_save_for_global_cleanup(\%obj); } return \%obj; } sub lock { my ($pid, $obj) = ($tid ? $$ .'.'. $tid : $$, shift); unless ($obj->{ $pid }) { CORE::lock($obj->{_t_lock}), MCE::Util::_sock_ready($obj->{_r_sock}) if $is_MSWin32; MCE::Util::_sysread($obj->{_r_sock}, my($b), 1), $obj->{ $pid } = 1; } return; } sub guard_lock { &lock(@_); bless([ $tid ? $$ .'.'. $tid : $$, $_[0] ], MCE::Mutex::Channel::_guard::); } *lock_exclusive = \&lock; *lock_shared = \&lock; sub unlock { my ($pid, $obj) = ($tid ? $$ .'.'. $tid : $$, shift); CORE::syswrite($obj->{_w_sock}, '0'), $obj->{ $pid } = 0 if $obj->{ $pid }; return; } sub synchronize { my ($pid, $obj, $code) = ($tid ? $$ .'.'. $tid : $$, shift, shift); my (@ret, $b); return unless ref($code) eq 'CODE'; # lock, run, unlock - inlined for performance my $guard = bless([ $pid, $obj ], MCE::Mutex::Channel::_guard::); unless ($obj->{ $pid }) { CORE::lock($obj->{_t_lock}), MCE::Util::_sock_ready($obj->{_r_sock}) if $is_MSWin32; MCE::Util::_sysread($obj->{_r_sock}, $b, 1), $obj->{ $pid } = 1; } (defined wantarray) ? @ret = wantarray ? $code->(@_) : scalar $code->(@_) : $code->(@_); return wantarray ? @ret : $ret[-1]; } *enter = \&synchronize; sub timedwait { my ($obj, $timeout) = @_; $timeout = 1 unless defined $timeout; Carp::croak('MCE::Mutex::Channel: timedwait (timeout) is not valid') if (!looks_like_number($timeout) || $timeout < 0); $timeout = 0.0003 if $timeout < 0.0003; local $@; my $ret = ''; eval { local $SIG{ALRM} = sub { alarm 0; die "alarm clock restart\n" }; alarm $timeout unless $is_MSWin32; die "alarm clock restart\n" if $is_MSWin32 && MCE::Util::_sock_ready($obj->{_r_sock}, $timeout); (!$is_MSWin32) ? ($obj->lock_exclusive, $ret = 1, alarm(0)) : ($obj->lock_exclusive, $ret = 1); }; alarm 0 unless $is_MSWin32; $ret; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Mutex::Channel - Mutex locking via a pipe or socket =head1 VERSION This document describes MCE::Mutex::Channel version 1.901 =head1 DESCRIPTION A pipe-socket implementation for C. The API is described in L. =over 3 =item new =item lock =item lock_exclusive =item lock_shared =item guard_lock =item unlock =item synchronize =item enter =item timedwait =back =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Mutex/Channel2.pm000644 000765 000024 00000011666 14735610752 016672 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## MCE::Mutex::Channel2 - Provides two mutexes using a single channel. ## ############################################################################### package MCE::Mutex::Channel2; use strict; use warnings; no warnings qw( threads recursion uninitialized once ); our $VERSION = '1.901'; use if $^O eq 'MSWin32', 'threads'; use if $^O eq 'MSWin32', 'threads::shared'; use base 'MCE::Mutex::Channel'; use MCE::Util (); use Scalar::Util 'looks_like_number'; use Time::HiRes 'alarm'; my $is_MSWin32 = ($^O eq 'MSWin32') ? 1 : 0; my $tid = $INC{'threads.pm'} ? threads->tid() : 0; sub CLONE { $tid = threads->tid() if $INC{'threads.pm'}; } sub MCE::Mutex::Channel2::_guard::DESTROY { my ($pid, $obj) = @{ $_[0] }; CORE::syswrite($obj->{_r_sock}, '0'), $obj->{$pid.'b'} = 0 if $obj->{$pid.'b'}; return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Public methods. ## ############################################################################### sub new { my ($class, %obj) = (@_, impl => 'Channel2'); $obj{_init_pid} = $tid ? $$ .'.'. $tid : $$; $obj{_t_lock} = threads::shared::share( my $t_lock ) if $is_MSWin32; $obj{_t_lock2} = threads::shared::share( my $t_lock2 ) if $is_MSWin32; MCE::Util::_sock_pair(\%obj, qw(_r_sock _w_sock), undef, 1); CORE::syswrite($obj{_w_sock}, '0'); CORE::syswrite($obj{_r_sock}, '0'); bless \%obj, $class; if ( caller !~ /^MCE:?/ || caller(1) !~ /^MCE:?/ ) { MCE::Mutex::Channel::_save_for_global_cleanup(\%obj); } return \%obj; } sub lock2 { my ($pid, $obj) = ($tid ? $$ .'.'. $tid : $$, shift); unless ($obj->{ $pid.'b' }) { CORE::lock($obj->{_t_lock2}), MCE::Util::_sock_ready($obj->{_w_sock}) if $is_MSWin32; MCE::Util::_sysread($obj->{_w_sock}, my($b), 1), $obj->{ $pid.'b' } = 1; } return; } sub guard_lock2 { &lock2(@_); bless([ $tid ? $$ .'.'. $tid : $$, $_[0] ], MCE::Mutex::Channel2::_guard::); } *lock_exclusive2 = \&lock2; *lock_shared2 = \&lock2; sub unlock2 { my ($pid, $obj) = ($tid ? $$ .'.'. $tid : $$, shift); CORE::syswrite($obj->{_r_sock}, '0'), $obj->{ $pid.'b' } = 0 if $obj->{ $pid.'b' }; return; } sub synchronize2 { my ($pid, $obj, $code) = ($tid ? $$ .'.'. $tid : $$, shift, shift); my (@ret, $b); return unless ref($code) eq 'CODE'; # lock, run, unlock - inlined for performance my $guard = bless([ $pid, $obj ], MCE::Mutex::Channel2::_guard::); unless ($obj->{ $pid.'b' }) { CORE::lock($obj->{_t_lock2}), MCE::Util::_sock_ready($obj->{_w_sock}) if $is_MSWin32; MCE::Util::_sysread($obj->{_w_sock}, $b, 1), $obj->{ $pid.'b' } = 1; } (defined wantarray) ? @ret = wantarray ? $code->(@_) : scalar $code->(@_) : $code->(@_); return wantarray ? @ret : $ret[-1]; } *enter2 = \&synchronize2; sub timedwait2 { my ($obj, $timeout) = @_; $timeout = 1 unless defined $timeout; Carp::croak('MCE::Mutex::Channel2: timedwait2 (timeout) is not valid') if (!looks_like_number($timeout) || $timeout < 0); $timeout = 0.0003 if $timeout < 0.0003; local $@; my $ret = ''; eval { local $SIG{ALRM} = sub { alarm 0; die "alarm clock restart\n" }; alarm $timeout unless $is_MSWin32; die "alarm clock restart\n" if $is_MSWin32 && MCE::Util::_sock_ready($obj->{_w_sock}, $timeout); (!$is_MSWin32) ? ($obj->lock_exclusive2, $ret = 1, alarm(0)) : ($obj->lock_exclusive2, $ret = 1); }; alarm 0 unless $is_MSWin32; $ret; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Mutex::Channel2 - Provides two mutexes using a single channel =head1 VERSION This document describes MCE::Mutex::Channel2 version 1.901 =head1 DESCRIPTION A socket implementation based on C. The secondary lock is accessed by calling methods with the C<2> suffix. The API is described in L. =head2 construction =over 3 =item new my $mutex = MCE::Mutex->new( impl => 'Channel2' ); =back =head2 primary lock =over 3 =item lock =item lock_exclusive =item lock_shared =item guard_lock =item unlock =item synchronize =item enter =item timedwait =back =head2 secondary lock =over 3 =item lock2 =item lock_exclusive2 =item lock_shared2 =item guard_lock2 =item unlock2 =item synchronize2 =item enter2 =item timedwait2 =back =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Mutex/Flock.pm000644 000765 000024 00000013502 14735610752 016265 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## MCE::Mutex::Flock - Mutex locking via Fcntl. ## ############################################################################### package MCE::Mutex::Flock; use strict; use warnings; no warnings qw( threads recursion uninitialized once ); our $VERSION = '1.901'; use base 'MCE::Mutex'; use Fcntl ':flock'; use Scalar::Util 'looks_like_number'; use Time::HiRes 'alarm'; my $tid = $INC{'threads.pm'} ? threads->tid() : 0; sub CLONE { $tid = threads->tid() if $INC{'threads.pm'}; } sub MCE::Mutex::Flock::_guard::DESTROY { my ($pid, $obj) = @{ $_[0] }; CORE::flock ($obj->{_fh}, LOCK_UN), $obj->{ $pid } = 0 if $obj->{ $pid }; return; } sub DESTROY { my ($pid, $obj) = ($tid ? $$ .'.'. $tid : $$, @_); $obj->unlock(), close(delete $obj->{_fh}) if $obj->{ $pid }; unlink $obj->{path} if ($obj->{_init} && $obj->{_init} eq $pid); return; } sub _open { my ($pid, $obj) = ($tid ? $$ .'.'. $tid : $$, @_); return if exists $obj->{ $pid }; open $obj->{_fh}, '+>>:raw:stdio', $obj->{path} or Carp::croak("Could not create temp file $obj->{path}: $!"); return; } ############################################################################### ## ---------------------------------------------------------------------------- ## Public methods. ## ############################################################################### my ($id, $prog_name) = (0); $prog_name = $0; $prog_name =~ s{^.*[\\/]}{}g; $prog_name = 'perl' if ($prog_name eq '-e' || $prog_name eq '-'); sub new { my ($class, %obj) = (@_, impl => 'Flock'); if (! defined $obj{path}) { my ($pid, $tmp_dir, $tmp_file) = ( abs($$) ); if ($ENV{TEMP} && -d $ENV{TEMP} && -w _) { if ($^O =~ /mswin|mingw|msys|cygwin/i) { $tmp_dir = $ENV{TEMP}; $tmp_dir .= ($^O eq 'MSWin32') ? "\\Perl-MCE" : "/Perl-MCE"; mkdir $tmp_dir unless (-d $tmp_dir); } else { $tmp_dir = $ENV{TEMP}; } } elsif ($ENV{TMPDIR} && -d $ENV{TMPDIR} && -w _) { $tmp_dir = $ENV{TMPDIR}; } elsif (-d '/tmp' && -w _) { $tmp_dir = '/tmp'; } else { Carp::croak("No writable dir found for a temp file"); } $id++, $tmp_dir =~ s{[\\/]$}{}; # remove tainted'ness from $tmp_dir if ($^O eq 'MSWin32') { ($tmp_file) = "$tmp_dir\\$prog_name.$pid.$tid.$id" =~ /(.*)/; } else { ($tmp_file) = "$tmp_dir/$prog_name.$pid.$tid.$id" =~ /(.*)/; } $obj{_init} = $tid ? $$ .'.'. $tid : $$; $obj{ path} = $tmp_file.'.lock'; # test open open my $fh, '+>>:raw:stdio', $obj{path} or Carp::croak("Could not create temp file $obj{path}: $!"); close $fh; # set permission chmod 0600, $obj{path}; } else { # test open open my $fh, '+>>:raw:stdio', $obj{path} or Carp::croak("Could not obtain flock on file $obj{path}: $!"); close $fh; } return bless(\%obj, $class); } sub lock { my ($pid, $obj) = ($tid ? $$ .'.'. $tid : $$, shift); $obj->_open() unless exists $obj->{ $pid }; CORE::flock ($obj->{_fh}, LOCK_EX), $obj->{ $pid } = 1 unless $obj->{ $pid }; return; } sub guard_lock { &lock(@_); bless([ $tid ? $$ .'.'. $tid : $$, $_[0] ], MCE::Mutex::Flock::_guard::); } *lock_exclusive = \&lock; sub lock_shared { my ($pid, $obj) = ($tid ? $$ .'.'. $tid : $$, shift); $obj->_open() unless exists $obj->{ $pid }; CORE::flock ($obj->{_fh}, LOCK_SH), $obj->{ $pid } = 1 unless $obj->{ $pid }; return; } sub unlock { my ($pid, $obj) = ($tid ? $$ .'.'. $tid : $$, shift); CORE::flock ($obj->{_fh}, LOCK_UN), $obj->{ $pid } = 0 if $obj->{ $pid }; return; } sub synchronize { my ($pid, $obj, $code) = ($tid ? $$ .'.'. $tid : $$, shift, shift); my (@ret); return unless ref($code) eq 'CODE'; $obj->_open() unless exists $obj->{ $pid }; # lock, run, unlock - inlined for performance my $guard = bless([ $pid, $obj ], MCE::Mutex::Flock::_guard::); unless ($obj->{ $pid }) { CORE::flock ($obj->{_fh}, LOCK_EX), $obj->{ $pid } = 1; } (defined wantarray) ? @ret = wantarray ? $code->(@_) : scalar $code->(@_) : $code->(@_); return wantarray ? @ret : $ret[-1]; } *enter = \&synchronize; sub timedwait { my ($obj, $timeout) = @_; die 'MCE::Mutex::Flock::timedwait() unimplemented in this platform' if ($^O eq 'MSWin32'); $timeout = 1 unless defined $timeout; Carp::croak('MCE::Mutex: timedwait (timeout) is not valid') if (!looks_like_number($timeout) || $timeout < 0); $timeout = 0.0003 if $timeout < 0.0003; local $@; local $SIG{ALRM} = sub { alarm 0; die "timed out\n" }; eval { alarm $timeout; $obj->lock_exclusive }; alarm 0; ( $@ && $@ eq "timed out\n" ) ? '' : 1; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Mutex::Flock - Mutex locking via Fcntl =head1 VERSION This document describes MCE::Mutex::Flock version 1.901 =head1 DESCRIPTION A Fcntl implementation for C. The API is described in L. =over 3 =item new =item lock =item lock_exclusive =item lock_shared =item guard_lock =item unlock =item synchronize =item enter =item timedwait =back =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Channel/ThreadsFast.pm000644 000765 000024 00000023147 14735610752 017713 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## Channel for producer(s) and many consumers supporting threads only. ## ############################################################################### package MCE::Channel::ThreadsFast; use strict; use warnings; no warnings qw( uninitialized once ); our $VERSION = '1.901'; use threads; use threads::shared; use base 'MCE::Channel'; my $LF = "\012"; Internals::SvREADONLY($LF, 1); my $is_MSWin32 = ( $^O eq 'MSWin32' ) ? 1 : 0; sub new { my ( $class, %obj ) = ( @_, impl => 'ThreadsFast' ); $obj{init_pid} = MCE::Channel::_pid(); MCE::Util::_sock_pair( \%obj, 'p_sock', 'c_sock' ); MCE::Util::_sock_pair( \%obj, 'p2_sock', 'c2_sock' ) if $is_MSWin32; # locking for the consumer side of the channel $obj{cr_mutex} = threads::shared::share( my $cr_mutex ); $obj{cw_mutex} = threads::shared::share( my $cw_mutex ); # optionally, support many-producers writing and reading $obj{pr_mutex} = threads::shared::share( my $pr_mutex ) if $obj{mp}; $obj{pw_mutex} = threads::shared::share( my $pw_mutex ) if $obj{mp}; return bless \%obj, $class; } ############################################################################### ## ---------------------------------------------------------------------------- ## Queue-like methods. ## ############################################################################### sub end { my ( $self ) = @_; local $\ = undef if (defined $\); MCE::Util::_sock_ready_w( $self->{p_sock} ) if $is_MSWin32; print { $self->{p_sock} } pack('i', -1); $self->{ended} = 1; } sub enqueue { my $self = shift; return MCE::Channel::_ended('enqueue') if $self->{ended}; local $\ = undef if (defined $\); { CORE::lock $self->{pw_mutex} if $self->{pw_mutex}; MCE::Util::_sock_ready_w( $self->{p_sock} ) if $is_MSWin32; while ( @_ ) { my $data = ''.shift; print { $self->{p_sock} } pack('i', length $data), $data; } } return 1; } sub dequeue { my ( $self, $count ) = @_; $count = 1 if ( !$count || $count < 1 ); if ( $count == 1 ) { my ( $plen, $data ); { CORE::lock $self->{cr_mutex}; MCE::Util::_sock_ready( $self->{c_sock} ) if $is_MSWin32; MCE::Util::_sysread( $self->{c_sock}, $plen, 4 ); my $len = unpack('i', $plen); if ( $len < 0 ) { $self->end; return wantarray ? () : undef; } return '' unless $len; MCE::Channel::_read( $self->{c_sock}, $data, $len ); } $data; } else { my ( $plen, @ret ); { CORE::lock $self->{cr_mutex}; MCE::Util::_sock_ready( $self->{c_sock} ) if $is_MSWin32; while ( $count-- ) { MCE::Util::_sysread( $self->{c_sock}, $plen, 4 ); my $len = unpack('i', $plen); if ( $len < 0 ) { $self->end; last; } push(@ret, ''), next unless $len; MCE::Channel::_read( $self->{c_sock}, my($data), $len ); push @ret, $data; } } wantarray ? @ret : $ret[-1]; } } sub dequeue_nb { my ( $self, $count ) = @_; $count = 1 if ( !$count || $count < 1 ); my ( $plen, @ret ); { CORE::lock $self->{cr_mutex}; while ( $count-- ) { MCE::Util::_nonblocking( $self->{c_sock}, 1 ); MCE::Util::_sysread( $self->{c_sock}, $plen, 4 ); MCE::Util::_nonblocking( $self->{c_sock}, 0 ); my $len; $len = unpack('i', $plen) if $plen; if ( !$len || $len < 0 ) { $self->end if defined $len && $len < 0; push @ret, '' if defined $len && $len == 0; last; } MCE::Channel::_read( $self->{c_sock}, my($data), $len ); push @ret, $data; } } wantarray ? @ret : $ret[-1]; } ############################################################################### ## ---------------------------------------------------------------------------- ## Methods for two-way communication; producer(s) to consumers. ## ############################################################################### sub send { my $self = shift; return MCE::Channel::_ended('send') if $self->{ended}; my $data = ''.shift; local $\ = undef if (defined $\); { CORE::lock $self->{pw_mutex} if $self->{pw_mutex}; MCE::Util::_sock_ready_w( $self->{p_sock} ) if $is_MSWin32; print { $self->{p_sock} } pack('i', length $data), $data; } return 1; } sub recv { my ( $self ) = @_; my ( $plen, $data ); { CORE::lock $self->{cr_mutex}; MCE::Util::_sock_ready( $self->{c_sock} ) if $is_MSWin32; MCE::Util::_sysread( $self->{c_sock}, $plen, 4 ); my $len = unpack('i', $plen); if ( $len < 0 ) { $self->end; return wantarray ? () : undef; } return '' unless $len; MCE::Channel::_read( $self->{c_sock}, $data, $len ); } $data; } sub recv_nb { my ( $self ) = @_; my ( $plen, $data ); { CORE::lock $self->{cr_mutex}; MCE::Util::_nonblocking( $self->{c_sock}, 1 ); MCE::Util::_sysread( $self->{c_sock}, $plen, 4 ); MCE::Util::_nonblocking( $self->{c_sock}, 0 ); my $len; $len = unpack('i', $plen) if $plen; if ( !$len || $len < 0 ) { $self->end if defined $len && $len < 0; return '' if defined $len && $len == 0; return wantarray ? () : undef; } MCE::Channel::_read( $self->{c_sock}, $data, $len ); } $data; } ############################################################################### ## ---------------------------------------------------------------------------- ## Methods for two-way communication; consumers to producer(s). ## ############################################################################### sub send2 { my $self = shift; my $data = ''.shift; local $\ = undef if (defined $\); { my $c_sock = $self->{c2_sock} || $self->{c_sock}; CORE::lock $self->{cw_mutex}; MCE::Util::_sock_ready_w( $c_sock ) if $is_MSWin32; print { $c_sock } pack('i', length $data), $data; } return 1; } sub recv2 { my ( $self ) = @_; my ( $plen, $data ); local $/ = $LF if ( $/ ne $LF ); { my $p_sock = $self->{p2_sock} || $self->{p_sock}; my $pr_mutex = $self->{pr_mutex}; CORE::lock $pr_mutex if $pr_mutex; MCE::Util::_sock_ready( $p_sock ) if $is_MSWin32; ( $pr_mutex || $is_MSWin32 ) ? MCE::Util::_sysread( $p_sock, $plen, 4 ) : read( $p_sock, $plen, 4 ); my $len = unpack('i', $plen); return '' unless $len; ( $pr_mutex || $is_MSWin32 ) ? MCE::Channel::_read( $p_sock, $data, $len ) : read( $p_sock, $data, $len ); } $data; } sub recv2_nb { my ( $self ) = @_; my ( $plen, $data ); local $/ = $LF if ( $/ ne $LF ); { my $p_sock = $self->{p2_sock} || $self->{p_sock}; my $pr_mutex = $self->{pr_mutex}; CORE::lock $pr_mutex if $pr_mutex; MCE::Util::_nonblocking( $p_sock, 1 ); ( $pr_mutex || $is_MSWin32 ) ? MCE::Util::_sysread( $p_sock, $plen, 4 ) : read( $p_sock, $plen, 4 ); MCE::Util::_nonblocking( $p_sock, 0 ); my $len; $len = unpack('i', $plen) if $plen; return '' if defined $len && $len == 0; return wantarray ? () : undef unless $len; ( $pr_mutex || $is_MSWin32 ) ? MCE::Channel::_read( $p_sock, $data, $len ) : read( $p_sock, $data, $len ); } $data; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Channel::ThreadsFast - Fast channel for producer(s) and many consumers =head1 VERSION This document describes MCE::Channel::ThreadsFast version 1.901 =head1 DESCRIPTION A channel class providing queue-like and two-way communication for threads only. Locking is handled using threads::shared. This is similar to L but optimized for non-Unicode strings only. The main difference is that this module lacks freeze-thaw serialization. Non-string arguments become stringified; i.e. numbers and undef. The API is described in L with the sole difference being C and C handle one argument. Current module available since MCE 1.877. =over 3 =item new use MCE::Channel; # The default is tuned for one producer and many consumers. my $chnl_a = MCE::Channel->new( impl => 'ThreadsFast' ); # Specify the 'mp' option for safe use by two or more producers # sending or receiving on the left side of the channel (i.e. # ->enqueue/->send or ->recv2/->recv2_nb). my $chnl_b = MCE::Channel->new( impl => 'ThreadsFast', mp => 1 ); =back =head1 QUEUE-LIKE BEHAVIOR =over 3 =item enqueue =item dequeue =item dequeue_nb =item end =back =head1 TWO-WAY IPC - PRODUCER TO CONSUMER =over 3 =item send =item recv =item recv_nb =back =head1 TWO-WAY IPC - CONSUMER TO PRODUCER =over 3 =item send2 =item recv2 =item recv2_nb =back =head1 LIMITATIONS The t/04_channel_threads tests are disabled on Unix platforms for Perl less than 5.10.1. Basically, the MCE::Channel::ThreadsFast implementation is not supported on older Perls unless the OS vendor applied upstream patches (i.e. works on RedHat/CentOS 5.x running Perl 5.8.x). =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Channel/Threads.pm000644 000765 000024 00000022551 14735610752 017073 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## Channel for producer(s) and many consumers supporting threads only. ## ############################################################################### package MCE::Channel::Threads; use strict; use warnings; no warnings qw( uninitialized once ); our $VERSION = '1.901'; use threads; use threads::shared; use base 'MCE::Channel'; my $LF = "\012"; Internals::SvREADONLY($LF, 1); my $is_MSWin32 = ( $^O eq 'MSWin32' ) ? 1 : 0; my $freeze = MCE::Channel::_get_freeze(); my $thaw = MCE::Channel::_get_thaw(); sub new { my ( $class, %obj ) = ( @_, impl => 'Threads' ); $obj{init_pid} = MCE::Channel::_pid(); MCE::Util::_sock_pair( \%obj, 'p_sock', 'c_sock' ); MCE::Util::_sock_pair( \%obj, 'p2_sock', 'c2_sock' ) if $is_MSWin32; # locking for the consumer side of the channel $obj{cr_mutex} = threads::shared::share( my $cr_mutex ); $obj{cw_mutex} = threads::shared::share( my $cw_mutex ); # optionally, support many-producers writing and reading $obj{pr_mutex} = threads::shared::share( my $pr_mutex ) if $obj{mp}; $obj{pw_mutex} = threads::shared::share( my $pw_mutex ) if $obj{mp}; return bless \%obj, $class; } ############################################################################### ## ---------------------------------------------------------------------------- ## Queue-like methods. ## ############################################################################### sub end { my ( $self ) = @_; local $\ = undef if (defined $\); MCE::Util::_sock_ready_w( $self->{p_sock} ) if $is_MSWin32; print { $self->{p_sock} } pack('i', -1); $self->{ended} = 1; } sub enqueue { my $self = shift; return MCE::Channel::_ended('enqueue') if $self->{ended}; local $\ = undef if (defined $\); { CORE::lock $self->{pw_mutex} if $self->{pw_mutex}; MCE::Util::_sock_ready_w( $self->{p_sock} ) if $is_MSWin32; while ( @_ ) { my $data = $freeze->([ shift ]); print { $self->{p_sock} } pack('i', length $data), $data; } } return 1; } sub dequeue { my ( $self, $count ) = @_; $count = 1 if ( !$count || $count < 1 ); if ( $count == 1 ) { my ( $plen, $data ); { CORE::lock $self->{cr_mutex}; MCE::Util::_sock_ready( $self->{c_sock} ) if $is_MSWin32; MCE::Util::_sysread( $self->{c_sock}, $plen, 4 ); my $len = unpack('i', $plen); if ( $len < 0 ) { $self->end; return wantarray ? () : undef; } MCE::Channel::_read( $self->{c_sock}, $data, $len ); } wantarray ? @{ $thaw->($data) } : ( $thaw->($data) )->[-1]; } else { my ( $plen, @ret ); { CORE::lock $self->{cr_mutex}; MCE::Util::_sock_ready( $self->{c_sock} ) if $is_MSWin32; while ( $count-- ) { MCE::Util::_sysread( $self->{c_sock}, $plen, 4 ); my $len = unpack('i', $plen); if ( $len < 0 ) { $self->end; last; } MCE::Channel::_read( $self->{c_sock}, my($data), $len ); push @ret, @{ $thaw->($data) }; } } wantarray ? @ret : $ret[-1]; } } sub dequeue_nb { my ( $self, $count ) = @_; $count = 1 if ( !$count || $count < 1 ); my ( $plen, @ret ); { CORE::lock $self->{cr_mutex}; while ( $count-- ) { MCE::Util::_nonblocking( $self->{c_sock}, 1 ); MCE::Util::_sysread( $self->{c_sock}, $plen, 4 ); MCE::Util::_nonblocking( $self->{c_sock}, 0 ); my $len; $len = unpack('i', $plen) if $plen; if ( !$len || $len < 0 ) { $self->end if defined $len && $len < 0; last; } MCE::Channel::_read( $self->{c_sock}, my($data), $len ); push @ret, @{ $thaw->($data) }; } } wantarray ? @ret : $ret[-1]; } ############################################################################### ## ---------------------------------------------------------------------------- ## Methods for two-way communication; producer(s) to consumers. ## ############################################################################### sub send { my $self = shift; return MCE::Channel::_ended('send') if $self->{ended}; my $data = $freeze->([ @_ ]); local $\ = undef if (defined $\); { CORE::lock $self->{pw_mutex} if $self->{pw_mutex}; MCE::Util::_sock_ready_w( $self->{p_sock} ) if $is_MSWin32; print { $self->{p_sock} } pack('i', length $data), $data; } return 1; } sub recv { my ( $self ) = @_; my ( $plen, $data ); { CORE::lock $self->{cr_mutex}; MCE::Util::_sock_ready( $self->{c_sock} ) if $is_MSWin32; MCE::Util::_sysread( $self->{c_sock}, $plen, 4 ); my $len = unpack('i', $plen); if ( $len < 0 ) { $self->end; return wantarray ? () : undef; } MCE::Channel::_read( $self->{c_sock}, $data, $len ); } wantarray ? @{ $thaw->($data) } : ( $thaw->($data) )->[-1]; } sub recv_nb { my ( $self ) = @_; my ( $plen, $data ); { CORE::lock $self->{cr_mutex}; MCE::Util::_nonblocking( $self->{c_sock}, 1 ); MCE::Util::_sysread( $self->{c_sock}, $plen, 4 ); MCE::Util::_nonblocking( $self->{c_sock}, 0 ); my $len; $len = unpack('i', $plen) if $plen; if ( !$len || $len < 0 ) { $self->end if defined $len && $len < 0; return wantarray ? () : undef; } MCE::Channel::_read( $self->{c_sock}, $data, $len ); } wantarray ? @{ $thaw->($data) } : ( $thaw->($data) )->[-1]; } ############################################################################### ## ---------------------------------------------------------------------------- ## Methods for two-way communication; consumers to producer(s). ## ############################################################################### sub send2 { my $self = shift; my $data = $freeze->([ @_ ]); local $\ = undef if (defined $\); { my $c_sock = $self->{c2_sock} || $self->{c_sock}; CORE::lock $self->{cw_mutex}; MCE::Util::_sock_ready_w( $c_sock ) if $is_MSWin32; print { $c_sock } pack('i', length $data), $data; } return 1; } sub recv2 { my ( $self ) = @_; my ( $plen, $data ); local $/ = $LF if ( $/ ne $LF ); { my $p_sock = $self->{p2_sock} || $self->{p_sock}; my $pr_mutex = $self->{pr_mutex}; CORE::lock $pr_mutex if $pr_mutex; MCE::Util::_sock_ready( $p_sock ) if $is_MSWin32; ( $pr_mutex || $is_MSWin32 ) ? MCE::Util::_sysread( $p_sock, $plen, 4 ) : read( $p_sock, $plen, 4 ); my $len = unpack('i', $plen); ( $pr_mutex || $is_MSWin32 ) ? MCE::Channel::_read( $p_sock, $data, $len ) : read( $p_sock, $data, $len ); } wantarray ? @{ $thaw->($data) } : ( $thaw->($data) )->[-1]; } sub recv2_nb { my ( $self ) = @_; my ( $plen, $data ); local $/ = $LF if ( $/ ne $LF ); { my $p_sock = $self->{p2_sock} || $self->{p_sock}; my $pr_mutex = $self->{pr_mutex}; CORE::lock $pr_mutex if $pr_mutex; MCE::Util::_nonblocking( $p_sock, 1 ); ( $pr_mutex || $is_MSWin32 ) ? MCE::Util::_sysread( $p_sock, $plen, 4 ) : read( $p_sock, $plen, 4 ); MCE::Util::_nonblocking( $p_sock, 0 ); my $len; $len = unpack('i', $plen) if $plen; return wantarray ? () : undef unless $len; ( $pr_mutex || $is_MSWin32 ) ? MCE::Channel::_read( $p_sock, $data, $len ) : read( $p_sock, $data, $len ); } wantarray ? @{ $thaw->($data) } : ( $thaw->($data) )->[-1]; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Channel::Threads - Channel for producer(s) and many consumers =head1 VERSION This document describes MCE::Channel::Threads version 1.901 =head1 DESCRIPTION A channel class providing queue-like and two-way communication for threads only. Locking is handled using threads::shared. The API is described in L. =over 3 =item new use MCE::Channel; # The default is tuned for one producer and many consumers. my $chnl_a = MCE::Channel->new( impl => 'Threads' ); # Specify the 'mp' option for safe use by two or more producers # sending or receiving on the left side of the channel (i.e. # ->enqueue/->send or ->recv2/->recv2_nb). my $chnl_b = MCE::Channel->new( impl => 'Threads', mp => 1 ); =back =head1 QUEUE-LIKE BEHAVIOR =over 3 =item enqueue =item dequeue =item dequeue_nb =item end =back =head1 TWO-WAY IPC - PRODUCER TO CONSUMER =over 3 =item send =item recv =item recv_nb =back =head1 TWO-WAY IPC - CONSUMER TO PRODUCER =over 3 =item send2 =item recv2 =item recv2_nb =back =head1 LIMITATIONS The t/04_channel_threads tests are disabled on Unix platforms for Perl less than 5.10.1. Basically, the MCE::Channel::Threads implementation is not supported on older Perls unless the OS vendor applied upstream patches (i.e. works on RedHat/CentOS 5.x running Perl 5.8.x). =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Channel/SimpleFast.pm000644 000765 000024 00000020521 14735610752 017543 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## Channel tuned for one producer and one consumer involving no locking. ## ############################################################################### package MCE::Channel::SimpleFast; use strict; use warnings; no warnings qw( uninitialized once ); our $VERSION = '1.901'; use base 'MCE::Channel'; my $LF = "\012"; Internals::SvREADONLY($LF, 1); my $is_MSWin32 = ( $^O eq 'MSWin32' ) ? 1 : 0; sub new { my ( $class, %obj ) = ( @_, impl => 'SimpleFast' ); $obj{init_pid} = MCE::Channel::_pid(); MCE::Util::_sock_pair( \%obj, 'p_sock', 'c_sock' ); return bless \%obj, $class; } ############################################################################### ## ---------------------------------------------------------------------------- ## Queue-like methods. ## ############################################################################### sub end { my ( $self ) = @_; local $\ = undef if (defined $\); MCE::Util::_sock_ready_w( $self->{p_sock} ) if $is_MSWin32; print { $self->{p_sock} } pack('i', -1); $self->{ended} = 1; } sub enqueue { my $self = shift; return MCE::Channel::_ended('enqueue') if $self->{ended}; local $\ = undef if (defined $\); MCE::Util::_sock_ready_w( $self->{p_sock} ) if $is_MSWin32; while ( @_ ) { my $data = ''.shift; print { $self->{p_sock} } pack('i', length $data) . $data; } return 1; } sub dequeue { my ( $self, $count ) = @_; $count = 1 if ( !$count || $count < 1 ); local $/ = $LF if ( $/ ne $LF ); if ( $count == 1 ) { my ( $plen, $data ); MCE::Util::_sock_ready( $self->{c_sock} ) if $is_MSWin32; $is_MSWin32 ? sysread( $self->{c_sock}, $plen, 4 ) : read( $self->{c_sock}, $plen, 4 ); my $len = unpack('i', $plen); if ( $len < 0 ) { $self->end; return wantarray ? () : undef; } return '' unless $len; $is_MSWin32 ? MCE::Channel::_read( $self->{c_sock}, $data, $len ) : read( $self->{c_sock}, $data, $len ); $data; } else { my ( $plen, @ret ); MCE::Util::_sock_ready( $self->{c_sock} ) if $is_MSWin32; while ( $count-- ) { my $data; $is_MSWin32 ? sysread( $self->{c_sock}, $plen, 4 ) : read( $self->{c_sock}, $plen, 4 ); my $len = unpack('i', $plen); if ( $len < 0 ) { $self->end; last; } push(@ret, ''), next unless $len; $is_MSWin32 ? MCE::Channel::_read( $self->{c_sock}, $data, $len ) : read( $self->{c_sock}, $data, $len ); push @ret, $data; } wantarray ? @ret : $ret[-1]; } } sub dequeue_nb { my ( $self, $count ) = @_; $count = 1 if ( !$count || $count < 1 ); my ( $plen, @ret ); local $/ = $LF if ( $/ ne $LF ); while ( $count-- ) { my $data; MCE::Util::_nonblocking( $self->{c_sock}, 1 ); $is_MSWin32 ? sysread( $self->{c_sock}, $plen, 4 ) : read( $self->{c_sock}, $plen, 4 ); MCE::Util::_nonblocking( $self->{c_sock}, 0 ); my $len; $len = unpack('i', $plen) if $plen; if ( !$len || $len < 0 ) { $self->end if defined $len && $len < 0; push @ret, '' if defined $len && $len == 0; last; } $is_MSWin32 ? MCE::Channel::_read( $self->{c_sock}, $data, $len ) : read( $self->{c_sock}, $data, $len ); push @ret, $data; } wantarray ? @ret : $ret[-1]; } ############################################################################### ## ---------------------------------------------------------------------------- ## Methods for two-way communication; producer(s) to consumers. ## ############################################################################### sub send { my $self = shift; return MCE::Channel::_ended('send') if $self->{ended}; my $data = ''.shift; local $\ = undef if (defined $\); MCE::Util::_sock_ready_w( $self->{p_sock} ) if $is_MSWin32; print { $self->{p_sock} } pack('i', length $data) . $data; return 1; } sub recv { my ( $self ) = @_; my ( $plen, $data ); local $/ = $LF if ( $/ ne $LF ); MCE::Util::_sock_ready( $self->{c_sock} ) if $is_MSWin32; $is_MSWin32 ? sysread( $self->{c_sock}, $plen, 4 ) : read( $self->{c_sock}, $plen, 4 ); my $len = unpack('i', $plen); if ( $len < 0 ) { $self->end; return wantarray ? () : undef; } return '' unless $len; $is_MSWin32 ? MCE::Channel::_read( $self->{c_sock}, $data, $len ) : read( $self->{c_sock}, $data, $len ); $data; } sub recv_nb { my ( $self ) = @_; my ( $plen, $data ); local $/ = $LF if ( $/ ne $LF ); MCE::Util::_nonblocking( $self->{c_sock}, 1 ); $is_MSWin32 ? sysread( $self->{c_sock}, $plen, 4 ) : read( $self->{c_sock}, $plen, 4 ); MCE::Util::_nonblocking( $self->{c_sock}, 0 ); my $len; $len = unpack('i', $plen) if $plen; if ( !$len || $len < 0 ) { $self->end if defined $len && $len < 0; return '' if defined $len && $len == 0; return wantarray ? () : undef; } $is_MSWin32 ? MCE::Channel::_read( $self->{c_sock}, $data, $len ) : read( $self->{c_sock}, $data, $len ); $data; } ############################################################################### ## ---------------------------------------------------------------------------- ## Methods for two-way communication; consumers to producer(s). ## ############################################################################### sub send2 { my $self = shift; my $data = ''.shift; local $\ = undef if (defined $\); MCE::Util::_sock_ready_w( $self->{c_sock} ) if $is_MSWin32; print { $self->{c_sock} } pack('i', length $data) . $data; return 1; } sub recv2 { my ( $self ) = @_; my ( $plen, $data ); local $/ = $LF if ( $/ ne $LF ); MCE::Util::_sock_ready( $self->{p_sock} ) if $is_MSWin32; $is_MSWin32 ? sysread( $self->{p_sock}, $plen, 4 ) : read( $self->{p_sock}, $plen, 4 ); my $len = unpack('i', $plen); return '' unless $len; $is_MSWin32 ? MCE::Channel::_read( $self->{p_sock}, $data, $len ) : read( $self->{p_sock}, $data, $len ); $data; } sub recv2_nb { my ( $self ) = @_; my ( $plen, $data ); local $/ = $LF if ( $/ ne $LF ); MCE::Util::_nonblocking( $self->{p_sock}, 1 ); $is_MSWin32 ? sysread( $self->{p_sock}, $plen, 4 ) : read( $self->{p_sock}, $plen, 4 ); MCE::Util::_nonblocking( $self->{p_sock}, 0 ); my $len; $len = unpack('i', $plen) if $plen; return '' if defined $len && $len == 0; return wantarray ? () : undef unless $len; $is_MSWin32 ? MCE::Channel::_read( $self->{p_sock}, $data, $len ) : read( $self->{p_sock}, $data, $len ); $data; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Channel::SimpleFast - Fast channel tuned for one producer and one consumer =head1 VERSION This document describes MCE::Channel::SimpleFast version 1.901 =head1 DESCRIPTION A channel class providing queue-like and two-way communication for one process or thread on either end; no locking needed. This is similar to L but optimized for non-Unicode strings only. The main difference is that this module lacks freeze-thaw serialization. Non-string arguments become stringified; i.e. numbers and undef. The API is described in L with the sole difference being C and C handle one argument. Current module available since MCE 1.877. =over 3 =item new use MCE::Channel; my $chnl = MCE::Channel->new( impl => 'SimpleFast' ); =back =head1 QUEUE-LIKE BEHAVIOR =over 3 =item enqueue =item dequeue =item dequeue_nb =item end =back =head1 TWO-WAY IPC - PRODUCER TO CONSUMER =over 3 =item send =item recv =item recv_nb =back =head1 TWO-WAY IPC - CONSUMER TO PRODUCER =over 3 =item send2 =item recv2 =item recv2_nb =back =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Channel/Simple.pm000644 000765 000024 00000020157 14735610752 016732 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## Channel tuned for one producer and one consumer involving no locking. ## ############################################################################### package MCE::Channel::Simple; use strict; use warnings; no warnings qw( uninitialized once ); our $VERSION = '1.901'; use base 'MCE::Channel'; my $LF = "\012"; Internals::SvREADONLY($LF, 1); my $is_MSWin32 = ( $^O eq 'MSWin32' ) ? 1 : 0; my $freeze = MCE::Channel::_get_freeze(); my $thaw = MCE::Channel::_get_thaw(); sub new { my ( $class, %obj ) = ( @_, impl => 'Simple' ); $obj{init_pid} = MCE::Channel::_pid(); MCE::Util::_sock_pair( \%obj, 'p_sock', 'c_sock' ); return bless \%obj, $class; } ############################################################################### ## ---------------------------------------------------------------------------- ## Queue-like methods. ## ############################################################################### sub end { my ( $self ) = @_; local $\ = undef if (defined $\); MCE::Util::_sock_ready_w( $self->{p_sock} ) if $is_MSWin32; print { $self->{p_sock} } pack('i', -1); $self->{ended} = 1; } sub enqueue { my $self = shift; return MCE::Channel::_ended('enqueue') if $self->{ended}; local $\ = undef if (defined $\); MCE::Util::_sock_ready_w( $self->{p_sock} ) if $is_MSWin32; while ( @_ ) { my $data = $freeze->([ shift ]); print { $self->{p_sock} } pack('i', length $data) . $data; } return 1; } sub dequeue { my ( $self, $count ) = @_; $count = 1 if ( !$count || $count < 1 ); local $/ = $LF if ( $/ ne $LF ); if ( $count == 1 ) { my ( $plen, $data ); MCE::Util::_sock_ready( $self->{c_sock} ) if $is_MSWin32; $is_MSWin32 ? sysread( $self->{c_sock}, $plen, 4 ) : read( $self->{c_sock}, $plen, 4 ); my $len = unpack('i', $plen); if ( $len < 0 ) { $self->end; return wantarray ? () : undef; } $is_MSWin32 ? MCE::Channel::_read( $self->{c_sock}, $data, $len ) : read( $self->{c_sock}, $data, $len ); wantarray ? @{ $thaw->($data) } : ( $thaw->($data) )->[-1]; } else { my ( $plen, @ret ); MCE::Util::_sock_ready( $self->{c_sock} ) if $is_MSWin32; while ( $count-- ) { my $data; $is_MSWin32 ? sysread( $self->{c_sock}, $plen, 4 ) : read( $self->{c_sock}, $plen, 4 ); my $len = unpack('i', $plen); if ( $len < 0 ) { $self->end; last; } $is_MSWin32 ? MCE::Channel::_read( $self->{c_sock}, $data, $len ) : read( $self->{c_sock}, $data, $len ); push @ret, @{ $thaw->($data) }; } wantarray ? @ret : $ret[-1]; } } sub dequeue_nb { my ( $self, $count ) = @_; $count = 1 if ( !$count || $count < 1 ); my ( $plen, @ret ); local $/ = $LF if ( $/ ne $LF ); while ( $count-- ) { my $data; MCE::Util::_nonblocking( $self->{c_sock}, 1 ); $is_MSWin32 ? sysread( $self->{c_sock}, $plen, 4 ) : read( $self->{c_sock}, $plen, 4 ); MCE::Util::_nonblocking( $self->{c_sock}, 0 ); my $len; $len = unpack('i', $plen) if $plen; if ( !$len || $len < 0 ) { $self->end if defined $len && $len < 0; last; } $is_MSWin32 ? MCE::Channel::_read( $self->{c_sock}, $data, $len ) : read( $self->{c_sock}, $data, $len ); push @ret, @{ $thaw->($data) }; } wantarray ? @ret : $ret[-1]; } ############################################################################### ## ---------------------------------------------------------------------------- ## Methods for two-way communication; producer(s) to consumers. ## ############################################################################### sub send { my $self = shift; return MCE::Channel::_ended('send') if $self->{ended}; my $data = $freeze->([ @_ ]); local $\ = undef if (defined $\); MCE::Util::_sock_ready_w( $self->{p_sock} ) if $is_MSWin32; print { $self->{p_sock} } pack('i', length $data) . $data; return 1; } sub recv { my ( $self ) = @_; my ( $plen, $data ); local $/ = $LF if ( $/ ne $LF ); MCE::Util::_sock_ready( $self->{c_sock} ) if $is_MSWin32; $is_MSWin32 ? sysread( $self->{c_sock}, $plen, 4 ) : read( $self->{c_sock}, $plen, 4 ); my $len = unpack('i', $plen); if ( $len < 0 ) { $self->end; return wantarray ? () : undef; } $is_MSWin32 ? MCE::Channel::_read( $self->{c_sock}, $data, $len ) : read( $self->{c_sock}, $data, $len ); wantarray ? @{ $thaw->($data) } : ( $thaw->($data) )->[-1]; } sub recv_nb { my ( $self ) = @_; my ( $plen, $data ); local $/ = $LF if ( $/ ne $LF ); MCE::Util::_nonblocking( $self->{c_sock}, 1 ); $is_MSWin32 ? sysread( $self->{c_sock}, $plen, 4 ) : read( $self->{c_sock}, $plen, 4 ); MCE::Util::_nonblocking( $self->{c_sock}, 0 ); my $len; $len = unpack('i', $plen) if $plen; if ( !$len || $len < 0 ) { $self->end if defined $len && $len < 0; return wantarray ? () : undef; } $is_MSWin32 ? MCE::Channel::_read( $self->{c_sock}, $data, $len ) : read( $self->{c_sock}, $data, $len ); wantarray ? @{ $thaw->($data) } : ( $thaw->($data) )->[-1]; } ############################################################################### ## ---------------------------------------------------------------------------- ## Methods for two-way communication; consumers to producer(s). ## ############################################################################### sub send2 { my $self = shift; my $data = $freeze->([ @_ ]); local $\ = undef if (defined $\); MCE::Util::_sock_ready_w( $self->{c_sock} ) if $is_MSWin32; print { $self->{c_sock} } pack('i', length $data) . $data; return 1; } sub recv2 { my ( $self ) = @_; my ( $plen, $data ); local $/ = $LF if ( $/ ne $LF ); MCE::Util::_sock_ready( $self->{p_sock} ) if $is_MSWin32; $is_MSWin32 ? sysread( $self->{p_sock}, $plen, 4 ) : read( $self->{p_sock}, $plen, 4 ); my $len = unpack('i', $plen); $is_MSWin32 ? MCE::Channel::_read( $self->{p_sock}, $data, $len ) : read( $self->{p_sock}, $data, $len ); wantarray ? @{ $thaw->($data) } : ( $thaw->($data) )->[-1]; } sub recv2_nb { my ( $self ) = @_; my ( $plen, $data ); local $/ = $LF if ( $/ ne $LF ); MCE::Util::_nonblocking( $self->{p_sock}, 1 ); $is_MSWin32 ? sysread( $self->{p_sock}, $plen, 4 ) : read( $self->{p_sock}, $plen, 4 ); MCE::Util::_nonblocking( $self->{p_sock}, 0 ); my $len; $len = unpack('i', $plen) if $plen; return wantarray ? () : undef unless $len; $is_MSWin32 ? MCE::Channel::_read( $self->{p_sock}, $data, $len ) : read( $self->{p_sock}, $data, $len ); wantarray ? @{ $thaw->($data) } : ( $thaw->($data) )->[-1]; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Channel::Simple - Channel tuned for one producer and one consumer =head1 VERSION This document describes MCE::Channel::Simple version 1.901 =head1 DESCRIPTION A channel class providing queue-like and two-way communication for one process or thread on either end; no locking needed. The API is described in L. =over 3 =item new use MCE::Channel; my $chnl = MCE::Channel->new( impl => 'Simple' ); =back =head1 QUEUE-LIKE BEHAVIOR =over 3 =item enqueue =item dequeue =item dequeue_nb =item end =back =head1 TWO-WAY IPC - PRODUCER TO CONSUMER =over 3 =item send =item recv =item recv_nb =back =head1 TWO-WAY IPC - CONSUMER TO PRODUCER =over 3 =item send2 =item recv2 =item recv2_nb =back =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Channel/MutexFast.pm000644 000765 000024 00000021532 14735610752 017417 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## Channel for producer(s) and many consumers supporting processes and threads. ## ############################################################################### package MCE::Channel::MutexFast; use strict; use warnings; no warnings qw( uninitialized once ); our $VERSION = '1.901'; use base 'MCE::Channel'; use MCE::Mutex (); my $LF = "\012"; Internals::SvREADONLY($LF, 1); sub new { my ( $class, %obj ) = ( @_, impl => 'MutexFast' ); $obj{init_pid} = MCE::Channel::_pid(); MCE::Util::_sock_pair( \%obj, 'p_sock', 'c_sock' ); # locking for the consumer side of the channel $obj{c_mutex} = MCE::Mutex->new( impl => 'Channel2' ); # optionally, support many-producers writing and reading $obj{p_mutex} = MCE::Mutex->new( impl => 'Channel2' ) if $obj{mp}; bless \%obj, $class; MCE::Mutex::Channel::_save_for_global_cleanup($obj{c_mutex}); MCE::Mutex::Channel::_save_for_global_cleanup($obj{p_mutex}) if $obj{mp}; return \%obj; } END { MCE::Child->finish('MCE') if $INC{'MCE/Child.pm'}; } ############################################################################### ## ---------------------------------------------------------------------------- ## Queue-like methods. ## ############################################################################### sub end { my ( $self ) = @_; local $\ = undef if (defined $\); print { $self->{p_sock} } pack('i', -1); $self->{ended} = 1; } sub enqueue { my $self = shift; return MCE::Channel::_ended('enqueue') if $self->{ended}; local $\ = undef if (defined $\); my $p_mutex = $self->{p_mutex}; $p_mutex->lock2 if $p_mutex; while ( @_ ) { my $data = ''.shift; print { $self->{p_sock} } pack('i', length $data), $data; } $p_mutex->unlock2 if $p_mutex; return 1; } sub dequeue { my ( $self, $count ) = @_; $count = 1 if ( !$count || $count < 1 ); if ( $count == 1 ) { ( my $c_mutex = $self->{c_mutex} )->lock; MCE::Util::_sysread( $self->{c_sock}, my($plen), 4 ); my $len = unpack('i', $plen); if ( $len < 0 ) { $self->end, $c_mutex->unlock; return wantarray ? () : undef; } MCE::Channel::_read( $self->{c_sock}, my($data), $len ) if $len; $c_mutex->unlock; $len ? $data : ''; } else { my ( $plen, @ret ); ( my $c_mutex = $self->{c_mutex} )->lock; while ( $count-- ) { MCE::Util::_sysread( $self->{c_sock}, $plen, 4 ); my $len = unpack('i', $plen); if ( $len < 0 ) { $self->end; last; } push(@ret, ''), next unless $len; MCE::Channel::_read( $self->{c_sock}, my($data), $len ); push @ret, $data; } $c_mutex->unlock; wantarray ? @ret : $ret[-1]; } } sub dequeue_nb { my ( $self, $count ) = @_; $count = 1 if ( !$count || $count < 1 ); my ( $plen, @ret ); ( my $c_mutex = $self->{c_mutex} )->lock; while ( $count-- ) { MCE::Util::_nonblocking( $self->{c_sock}, 1 ); MCE::Util::_sysread( $self->{c_sock}, $plen, 4 ); MCE::Util::_nonblocking( $self->{c_sock}, 0 ); my $len; $len = unpack('i', $plen) if $plen; if ( !$len || $len < 0 ) { $self->end if defined $len && $len < 0; push @ret, '' if defined $len && $len == 0; last; } MCE::Channel::_read( $self->{c_sock}, my($data), $len ); push @ret, $data; } $c_mutex->unlock; wantarray ? @ret : $ret[-1]; } ############################################################################### ## ---------------------------------------------------------------------------- ## Methods for two-way communication; producer to consumer. ## ############################################################################### sub send { my $self = shift; return MCE::Channel::_ended('send') if $self->{ended}; my $data = ''.shift; local $\ = undef if (defined $\); my $p_mutex = $self->{p_mutex}; $p_mutex->lock2 if $p_mutex; print { $self->{p_sock} } pack('i', length $data), $data; $p_mutex->unlock2 if $p_mutex; return 1; } sub recv { my ( $self ) = @_; ( my $c_mutex = $self->{c_mutex} )->lock; MCE::Util::_sysread( $self->{c_sock}, my($plen), 4 ); my $len = unpack('i', $plen); if ( $len < 0 ) { $self->end, $c_mutex->unlock; return wantarray ? () : undef; } MCE::Channel::_read( $self->{c_sock}, my($data), $len ) if $len; $c_mutex->unlock; $len ? $data : ''; } sub recv_nb { my ( $self ) = @_; ( my $c_mutex = $self->{c_mutex} )->lock; MCE::Util::_nonblocking( $self->{c_sock}, 1 ); MCE::Util::_sysread( $self->{c_sock}, my($plen), 4 ); MCE::Util::_nonblocking( $self->{c_sock}, 0 ); my $len; $len = unpack('i', $plen) if $plen; if ( !$len || $len < 0 ) { $self->end if defined $len && $len < 0; $c_mutex->unlock; return '' if defined $len && $len == 0; return wantarray ? () : undef; } MCE::Channel::_read( $self->{c_sock}, my($data), $len ); $c_mutex->unlock; $data; } ############################################################################### ## ---------------------------------------------------------------------------- ## Methods for two-way communication; consumer to producer. ## ############################################################################### sub send2 { my $self = shift; my $data = ''.shift; my $sig; { local $SIG{ABRT} = local $SIG{HUP} = local $SIG{QUIT} = local $SIG{INT} = local $SIG{TERM} = sub { $sig = $_[0]; }; local $\ = undef if (defined $\); $self->{c_mutex}->synchronize2( sub { print { $self->{c_sock} } pack('i', length $data), $data; }); } CORE::kill($sig, $$) if $sig; return 1; } sub recv2 { my ( $self ) = @_; my ( $plen, $data ); local $/ = $LF if ( $/ ne $LF ); my $p_mutex = $self->{p_mutex}; $p_mutex->lock if $p_mutex; ( $p_mutex ) ? MCE::Util::_sysread( $self->{p_sock}, $plen, 4 ) : read( $self->{p_sock}, $plen, 4 ); my $len = unpack('i', $plen); if ( $len ) { ( $p_mutex ) ? MCE::Channel::_read( $self->{p_sock}, $data, $len ) : read( $self->{p_sock}, $data, $len ); } $p_mutex->unlock if $p_mutex; $len ? $data : ''; } sub recv2_nb { my ( $self ) = @_; my ( $plen, $data ); local $/ = $LF if ( $/ ne $LF ); my $p_mutex = $self->{p_mutex}; $p_mutex->lock if $p_mutex; MCE::Util::_nonblocking( $self->{p_sock}, 1 ); ( $p_mutex ) ? MCE::Util::_sysread( $self->{p_sock}, $plen, 4 ) : read( $self->{p_sock}, $plen, 4 ); MCE::Util::_nonblocking( $self->{p_sock}, 0 ); my $len; $len = unpack('i', $plen) if $plen; if ( !$len ) { $p_mutex->unlock if $p_mutex; return '' if defined $len && $len == 0; return wantarray ? () : undef; } ( $p_mutex ) ? MCE::Channel::_read( $self->{p_sock}, $data, $len ) : read( $self->{p_sock}, $data, $len ); $p_mutex->unlock if $p_mutex; $data; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Channel::MutexFast - Fast channel for producer(s) and many consumers =head1 VERSION This document describes MCE::Channel::MutexFast version 1.901 =head1 DESCRIPTION A channel class providing queue-like and two-way communication for processes and threads. Locking is handled using MCE::Mutex. This is similar to L but optimized for non-Unicode strings only. The main difference is that this module lacks freeze-thaw serialization. Non-string arguments become stringified; i.e. numbers and undef. The API is described in L with the sole difference being C and C handle one argument. Current module available since MCE 1.877. =over 3 =item new use MCE::Channel; # The default is tuned for one producer and many consumers. my $chnl_a = MCE::Channel->new( impl => 'MutexFast' ); # Specify the 'mp' option for safe use by two or more producers # sending or receiving on the left side of the channel (i.e. # ->enqueue/->send or ->recv2/->recv2_nb). my $chnl_b = MCE::Channel->new( impl => 'MutexFast', mp => 1 ); =back =head1 QUEUE-LIKE BEHAVIOR =over 3 =item enqueue =item dequeue =item dequeue_nb =item end =back =head1 TWO-WAY IPC - PRODUCER TO CONSUMER =over 3 =item send =item recv =item recv_nb =back =head1 TWO-WAY IPC - CONSUMER TO PRODUCER =over 3 =item send2 =item recv2 =item recv2_nb =back =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Channel/Mutex.pm000644 000765 000024 00000021163 14735610752 016601 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## Channel for producer(s) and many consumers supporting processes and threads. ## ############################################################################### package MCE::Channel::Mutex; use strict; use warnings; no warnings qw( uninitialized once ); our $VERSION = '1.901'; use base 'MCE::Channel'; use MCE::Mutex (); my $LF = "\012"; Internals::SvREADONLY($LF, 1); my $freeze = MCE::Channel::_get_freeze(); my $thaw = MCE::Channel::_get_thaw(); sub new { my ( $class, %obj ) = ( @_, impl => 'Mutex' ); $obj{init_pid} = MCE::Channel::_pid(); MCE::Util::_sock_pair( \%obj, 'p_sock', 'c_sock' ); # locking for the consumer side of the channel $obj{c_mutex} = MCE::Mutex->new( impl => 'Channel2' ); # optionally, support many-producers writing and reading $obj{p_mutex} = MCE::Mutex->new( impl => 'Channel2' ) if $obj{mp}; bless \%obj, $class; MCE::Mutex::Channel::_save_for_global_cleanup($obj{c_mutex}); MCE::Mutex::Channel::_save_for_global_cleanup($obj{p_mutex}) if $obj{mp}; return \%obj; } END { MCE::Child->finish('MCE') if $INC{'MCE/Child.pm'}; } ############################################################################### ## ---------------------------------------------------------------------------- ## Queue-like methods. ## ############################################################################### sub end { my ( $self ) = @_; local $\ = undef if (defined $\); print { $self->{p_sock} } pack('i', -1); $self->{ended} = 1; } sub enqueue { my $self = shift; return MCE::Channel::_ended('enqueue') if $self->{ended}; local $\ = undef if (defined $\); my $p_mutex = $self->{p_mutex}; $p_mutex->lock2 if $p_mutex; while ( @_ ) { my $data = $freeze->([ shift ]); print { $self->{p_sock} } pack('i', length $data), $data; } $p_mutex->unlock2 if $p_mutex; return 1; } sub dequeue { my ( $self, $count ) = @_; $count = 1 if ( !$count || $count < 1 ); if ( $count == 1 ) { ( my $c_mutex = $self->{c_mutex} )->lock; MCE::Util::_sysread( $self->{c_sock}, my($plen), 4 ); my $len = unpack('i', $plen); if ( $len < 0 ) { $self->end, $c_mutex->unlock; return wantarray ? () : undef; } MCE::Channel::_read( $self->{c_sock}, my($data), $len ); $c_mutex->unlock; wantarray ? @{ $thaw->($data) } : ( $thaw->($data) )->[-1]; } else { my ( $plen, @ret ); ( my $c_mutex = $self->{c_mutex} )->lock; while ( $count-- ) { MCE::Util::_sysread( $self->{c_sock}, $plen, 4 ); my $len = unpack('i', $plen); if ( $len < 0 ) { $self->end; last; } MCE::Channel::_read( $self->{c_sock}, my($data), $len ); push @ret, @{ $thaw->($data) }; } $c_mutex->unlock; wantarray ? @ret : $ret[-1]; } } sub dequeue_nb { my ( $self, $count ) = @_; $count = 1 if ( !$count || $count < 1 ); my ( $plen, @ret ); ( my $c_mutex = $self->{c_mutex} )->lock; while ( $count-- ) { MCE::Util::_nonblocking( $self->{c_sock}, 1 ); MCE::Util::_sysread( $self->{c_sock}, $plen, 4 ); MCE::Util::_nonblocking( $self->{c_sock}, 0 ); my $len; $len = unpack('i', $plen) if $plen; if ( !$len || $len < 0 ) { $self->end if defined $len && $len < 0; last; } MCE::Channel::_read( $self->{c_sock}, my($data), $len ); push @ret, @{ $thaw->($data) }; } $c_mutex->unlock; wantarray ? @ret : $ret[-1]; } ############################################################################### ## ---------------------------------------------------------------------------- ## Methods for two-way communication; producer to consumer. ## ############################################################################### sub send { my $self = shift; return MCE::Channel::_ended('send') if $self->{ended}; my $data = $freeze->([ @_ ]); local $\ = undef if (defined $\); my $p_mutex = $self->{p_mutex}; $p_mutex->lock2 if $p_mutex; print { $self->{p_sock} } pack('i', length $data), $data; $p_mutex->unlock2 if $p_mutex; return 1; } sub recv { my ( $self ) = @_; ( my $c_mutex = $self->{c_mutex} )->lock; MCE::Util::_sysread( $self->{c_sock}, my($plen), 4 ); my $len = unpack('i', $plen); if ( $len < 0 ) { $self->end, $c_mutex->unlock; return wantarray ? () : undef; } MCE::Channel::_read( $self->{c_sock}, my($data), $len ); $c_mutex->unlock; wantarray ? @{ $thaw->($data) } : ( $thaw->($data) )->[-1]; } sub recv_nb { my ( $self ) = @_; ( my $c_mutex = $self->{c_mutex} )->lock; MCE::Util::_nonblocking( $self->{c_sock}, 1 ); MCE::Util::_sysread( $self->{c_sock}, my($plen), 4 ); MCE::Util::_nonblocking( $self->{c_sock}, 0 ); my $len; $len = unpack('i', $plen) if $plen; if ( !$len || $len < 0 ) { $self->end if defined $len && $len < 0; $c_mutex->unlock; return wantarray ? () : undef; } MCE::Channel::_read( $self->{c_sock}, my($data), $len ); $c_mutex->unlock; wantarray ? @{ $thaw->($data) } : ( $thaw->($data) )->[-1]; } ############################################################################### ## ---------------------------------------------------------------------------- ## Methods for two-way communication; consumer to producer. ## ############################################################################### sub send2 { my $self = shift; my $data = $freeze->([ @_ ]); my $sig; { local $SIG{ABRT} = local $SIG{HUP} = local $SIG{QUIT} = local $SIG{INT} = local $SIG{TERM} = sub { $sig = $_[0]; }; local $\ = undef if (defined $\); $self->{c_mutex}->synchronize2( sub { print { $self->{c_sock} } pack('i', length $data), $data; }); } CORE::kill($sig, $$) if $sig; return 1; } sub recv2 { my ( $self ) = @_; my ( $plen, $data ); local $/ = $LF if ( $/ ne $LF ); my $p_mutex = $self->{p_mutex}; $p_mutex->lock if $p_mutex; ( $p_mutex ) ? MCE::Util::_sysread( $self->{p_sock}, $plen, 4 ) : read( $self->{p_sock}, $plen, 4 ); my $len = unpack('i', $plen); ( $p_mutex ) ? MCE::Channel::_read( $self->{p_sock}, $data, $len ) : read( $self->{p_sock}, $data, $len ); $p_mutex->unlock if $p_mutex; wantarray ? @{ $thaw->($data) } : ( $thaw->($data) )->[-1]; } sub recv2_nb { my ( $self ) = @_; my ( $plen, $data ); local $/ = $LF if ( $/ ne $LF ); my $p_mutex = $self->{p_mutex}; $p_mutex->lock if $p_mutex; MCE::Util::_nonblocking( $self->{p_sock}, 1 ); ( $p_mutex ) ? MCE::Util::_sysread( $self->{p_sock}, $plen, 4 ) : read( $self->{p_sock}, $plen, 4 ); MCE::Util::_nonblocking( $self->{p_sock}, 0 ); my $len; $len = unpack('i', $plen) if $plen; if ( !$len ) { $p_mutex->unlock if $p_mutex; return wantarray ? () : undef; } ( $p_mutex ) ? MCE::Channel::_read( $self->{p_sock}, $data, $len ) : read( $self->{p_sock}, $data, $len ); $p_mutex->unlock if $p_mutex; wantarray ? @{ $thaw->($data) } : ( $thaw->($data) )->[-1]; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Channel::Mutex - Channel for producer(s) and many consumers =head1 VERSION This document describes MCE::Channel::Mutex version 1.901 =head1 DESCRIPTION A channel class providing queue-like and two-way communication for processes and threads. Locking is handled using MCE::Mutex. The API is described in L. =over 3 =item new use MCE::Channel; # The default is tuned for one producer and many consumers. my $chnl_a = MCE::Channel->new( impl => 'Mutex' ); # Specify the 'mp' option for safe use by two or more producers # sending or receiving on the left side of the channel (i.e. # ->enqueue/->send or ->recv2/->recv2_nb). my $chnl_b = MCE::Channel->new( impl => 'Mutex', mp => 1 ); =back =head1 QUEUE-LIKE BEHAVIOR =over 3 =item enqueue =item dequeue =item dequeue_nb =item end =back =head1 TWO-WAY IPC - PRODUCER TO CONSUMER =over 3 =item send =item recv =item recv_nb =back =head1 TWO-WAY IPC - CONSUMER TO PRODUCER =over 3 =item send2 =item recv2 =item recv2_nb =back =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Core/Worker.pm000644 000765 000024 00000053470 14735610752 016276 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## 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.901'; my $_tid = $INC{'threads.pm'} ? threads->tid() : 0; sub CLONE { $_tid = threads->tid() if $INC{'threads.pm'}; } ## Items below are folded into MCE. package # hide from rpm MCE; no warnings qw( bareword threads recursion uninitialized ); ############################################################################### ## ---------------------------------------------------------------------------- ## 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 ); my $_is_MSWin32 = ($^O eq 'MSWin32') ? 1 : 0; ## 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 ${ $_[1] }) { my $_buf = $_[0]->{freeze}([ $_val, ${ $_[1] } ]); $_dat_ex->() if $_lock_chn; print({$_DAT_W_SOCK} OUTPUT_F_SND.$LF . $_chn.$LF), print({$_DAU_W_SOCK} length($_buf).$LF, $_buf); $_dat_un->() if $_lock_chn; } return; }; $_dest_function[SENDTO_FD] = sub { ## Content >> File descriptor return unless (defined $_val); local $\ = undef if (defined $\); if (length ${ $_[1] }) { my $_buf = $_[0]->{freeze}([ $_val, ${ $_[1] } ]); $_dat_ex->() if $_lock_chn; print({$_DAT_W_SOCK} OUTPUT_D_SND.$LF . $_chn.$LF), print({$_DAU_W_SOCK} length($_buf).$LF, $_buf); $_dat_un->() if $_lock_chn; } return; }; $_dest_function[SENDTO_STDOUT] = sub { ## Content >> STDOUT local $\ = undef if (defined $\); if (length ${ $_[1] }) { my $_buf = $_[0]->{freeze}($_[1]); $_dat_ex->() if $_lock_chn; print({$_DAT_W_SOCK} OUTPUT_O_SND.$LF . $_chn.$LF), print({$_DAU_W_SOCK} length($_buf).$LF, $_buf); $_dat_un->() if $_lock_chn; } return; }; $_dest_function[SENDTO_STDERR] = sub { ## Content >> STDERR local $\ = undef if (defined $\); if (length ${ $_[1] }) { my $_buf = $_[0]->{freeze}($_[1]); $_dat_ex->() if $_lock_chn; print({$_DAT_W_SOCK} OUTPUT_E_SND.$LF . $_chn.$LF), print({$_DAU_W_SOCK} length($_buf).$LF, $_buf); $_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; } local $\ = undef if (defined $\); ## Crossover: Send arguments if ( ! @{ $_aref } ) { $_dat_ex->() if $_lock_chn; print({$_DAT_W_SOCK} OUTPUT_N_CBK.$LF . $_chn.$LF), print({$_DAU_W_SOCK} $_wa.$LF . $_val.$LF); } else { $_buf = $self->{freeze}($_aref); $_len = length $_buf; $_dat_ex->() if $_lock_chn; print({$_DAT_W_SOCK} OUTPUT_A_CBK.$LF . $_chn.$LF), print({$_DAU_W_SOCK} $_wa.$LF . $_val.$LF . $_len.$LF, $_buf); } ## Crossover: Receive value if ( $_wa ) { local $/ = $LF if ($/ ne $LF); chomp(my $_len = <$_DAU_W_SOCK>); read $_DAU_W_SOCK, my($_buf), $_len; $_dat_un->() if $_lock_chn; return ( $_wa != WANTS_ARRAY ) ? ($self->{thaw}($_buf))->[0] : @{ $self->{thaw}($_buf) }; } $_dat_un->() if $_lock_chn; } ## ------------------------------------------------------------------------- sub _do_gather { my $_buf; my ($self, $_aref) = @_; return unless (scalar @{ $_aref }); $_tag = OUTPUT_A_GTR; $_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} $_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]($self, $_data_ref); return 1; } 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 { use bytes; my $_fh = _sendto_fhs_get($self, $_fd); local $\ = undef if (defined $\); print {$_fh} ${ $_data_ref }; } return 1; } ## ------------------------------------------------------------------------- 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) { # inlined for performance $_dat_ex = sub { my $_pid = $_tid ? $$ .'.'. $_tid : $$; CORE::lock($_DAT_LOCK->{_t_lock}), MCE::Util::_sock_ready($_DAT_LOCK->{_r_sock}) if $_is_MSWin32; MCE::Util::_sysread($_DAT_LOCK->{_r_sock}, my($b), 1), $_DAT_LOCK->{ $_pid } = 1 unless $_DAT_LOCK->{ $_pid }; }; $_dat_un = sub { my $_pid = $_tid ? $$ .'.'. $_tid : $$; syswrite($_DAT_LOCK->{_w_sock}, '0'), $_DAT_LOCK->{ $_pid } = 0 if $_DAT_LOCK->{ $_pid }; }; } { local $!; (*STDERR)->autoflush(1) if defined( fileno *STDERR ); (*STDOUT)->autoflush(1) 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) = @_; my $_size = 0; delete $self->{_relayed}; $self->{_chunk_id} = $_chunk_id; if ($self->{progress} && $self->{_task_id} == 0) { # use_slurpio if (ref $_chunk eq 'SCALAR') { $_size += length ${ $_chunk }; } # sequence and bounds_only elsif ($self->{sequence} && $self->{bounds_only}) { my $_seq = $self->{sequence}; my $_step = (ref $_seq eq 'ARRAY') ? $_seq->[2] : $_seq->{step}; $_size += int(abs($_chunk->[0] - $_chunk->[1]) / abs($_step)) + 1; } # workers clear {input_data} to conserve memory when array ref # otherwise, /path/to/infile or scalar reference elsif ($self->{input_data}) { map { $_size += length } @{ $_chunk }; } # array or sequence else { $_size += (ref $_chunk eq 'ARRAY') ? @{ $_chunk } : 1; } } if ($self->{max_retries}) { $self->{_retry} = [ $_chunk, $_chunk_id, $self->{max_retries} ]; } if ($self->{loop_timeout} && $self->{_task_id} == 0 && defined $self->{init_relay} && !$self->{_is_thread} && !$_is_MSWin32) { local $\ = undef if (defined $\); $_dat_ex->() if $_lock_chn; print({$_DAT_W_SOCK} OUTPUT_C_NFY.$LF . $_chn.$LF), print({$_DAU_W_SOCK} "$$:$_chunk_id".$LF); $_dat_un->() if $_lock_chn; } $_user_func->($self, $_chunk, $_chunk_id); if ($self->{progress} && $self->{_task_id} == 0) { local $\ = undef if (defined $\); $_dat_ex->() if $_lock_chn; print({$_DAT_W_SOCK} OUTPUT_P_NFY.$LF . $_chn.$LF), print({$_DAU_W_SOCK} $_size.$LF); $_dat_un->() if $_lock_chn; } return; } sub _do_user_func_init { my ($self) = @_; $_user_func = $self->{user_func}; return; } } ############################################################################### ## ---------------------------------------------------------------------------- ## Worker process -- Do. ## ############################################################################### sub MCE::Core::Worker::_guard::DESTROY { my ($mce, $id) = @{ $_[0] }; if (defined $mce && $id eq "$$.$_tid") { @{ $_[0] } = (); warn "MCE worker $id exited prematurely.\n"; $mce->exit(2); } return; }; sub _worker_do { my ($self, $_params_ref) = @_; @_ = (); ## Set options. $self->{_abort_msg} = $_params_ref->{_abort_msg}; $self->{_run_mode} = $_params_ref->{_run_mode}; $self->{use_slurpio} = $_params_ref->{_use_slurpio}; $self->{parallel_io} = $_params_ref->{_parallel_io}; $self->{progress} = $_params_ref->{_progress}; $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 sequence user_args)) { if (defined $_params_ref->{"_${_p}"}) { $self->{$_p} = $_params_ref->{"_${_p}"} unless (defined $self->{_task}->{$_p}); } } { my $_guard = bless([ $self, "$$.$_tid" ], MCE::Core::Worker::_guard::); weaken( $self->{_guard} = $_guard ); ## Assign user function. $self->{_wuf} = \&_do_user_func; ## Call user_begin if defined. if (defined $self->{user_begin}) { $self->{_chunk_id} = 0; $self->{user_begin}($self, $_task_id, $_task_name); if ($_task_id == 0 && defined $self->{init_relay} && !$self->{_retry}) { $self->sync(); } } ## 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 $INC{'MCE/Core/Input/Sequence.pm'}; _worker_sequence_queue($self); } elsif (defined $self->{_task}->{sequence}) { require MCE::Core::Input::Generator unless $INC{'MCE/Core/Input/Generator.pm'}; _worker_sequence_generator($self); } elsif ($_run_mode eq 'array') { require MCE::Core::Input::Request unless $INC{'MCE/Core/Input/Request.pm'}; _worker_request_chunk($self, REQUEST_ARRAY); } elsif ($_run_mode eq 'glob') { require MCE::Core::Input::Request unless $INC{'MCE/Core/Input/Request.pm'}; _worker_request_chunk($self, REQUEST_GLOB); } elsif ($_run_mode eq 'hash') { require MCE::Core::Input::Request unless $INC{'MCE/Core/Input/Request.pm'}; _worker_request_chunk($self, REQUEST_HASH); } elsif ($_run_mode eq 'iterator') { require MCE::Core::Input::Iterator unless $INC{'MCE/Core/Input/Iterator.pm'}; _worker_user_iterator($self); } elsif ($_run_mode eq 'file') { require MCE::Core::Input::Handle unless $INC{'MCE/Core/Input/Handle.pm'}; _worker_read_handle($self, READ_FILE, $_params_ref->{_input_file}); } elsif ($_run_mode eq 'memory') { require MCE::Core::Input::Handle unless $INC{'MCE/Core/Input/Handle.pm'}; _worker_read_handle($self, READ_MEMORY, $self->{input_data}); } elsif (defined $self->{user_func}) { if ($self->{max_retries}) { $self->{_retry} = [ undef, 0, $self->{max_retries} ]; } $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); } @{ $_guard } = (); delete $self->{_guard}; delete $self->{_wuf}; } ## Check for nested workers not yet joined. MCE::Child->finish('MCE') if $INC{'MCE/Child.pm'}; 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}; if ($^O eq 'MSWin32') { lock $MCE::_WIN_LOCK; } while (1) { { local $\ = undef; local $/ = $LF; $_COM_LOCK->lock(); ## Wait for the next job request. $_response = <$_COM_W_SOCK>, print {$_COM_W_SOCK} $self->{_wid}.$LF; ## Return if instructed to exit. $_COM_LOCK->unlock(), return if ($_response eq "_exit\n"); ## Process send request. if ($_response eq "_data\n") { chomp($_len = <$_COM_W_SOCK>), read($_COM_W_SOCK, $_buf, $_len); print({$_COM_W_SOCK} $LF), $_COM_LOCK->unlock(); $self->{user_data} = $self->{thaw}($_buf), undef $_buf; sleep $_job_delay * $self->{_wid} if defined($_job_delay) && $_job_delay > 0.0; } ## Process normal request. elsif ($_response =~ /\d+/) { chomp($_len = <$_COM_W_SOCK>), read($_COM_W_SOCK, $_buf, $_len); print({$_COM_W_SOCK} $LF), $_COM_LOCK->unlock(); $_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. MCE::Util::_sysread($self->{_bsb_w_sock}, my($_b), 1); ## Normal request. sleep $_job_delay * $self->{_wid} if defined($_job_delay) && $_job_delay > 0.0; _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_LOCK->unlock(); die "Error: 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_' . $_tid; } else { $self->{_exit_pid} = 'PID_' . $$; } my $_running_inside_eval = $^S; local $SIG{SEGV} = sub { $self->exit(11) }; local $SIG{__DIE__} = sub { if (!defined $^S || $^S) { if ( ($INC{'threads.pm'} && $_tid != 0) || $ENV{'PERL_IPERL_RUNNING'} || $_running_inside_eval ) { # 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(@_); } } $SIG{__DIE__} = $SIG{__WARN__} = sub {}; my $_die_msg = (defined $_[0]) ? $_[0] : ''; $_die_msg =~ s/, <__ANONIO__> line \d+//; local $\ = undef; 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->{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 $_chn; if (defined $_params && exists $_params->{_chn}) { $_chn = $self->{_chn} = delete $_params->{_chn}; # worker restarted } else { $_chn = $self->{_chn} = $_wid % $self->{_data_channels} + 1; # default } ## 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. ## For threads, init is called automatically via the CLONE feature. MCE::Shared::init() if (!$_use_threads && $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. _worker_do($self, $_params), undef $_params if defined($_params); ## Enter worker loop. _worker_loop($self); ## Clear worker session. _do_send_clear($self); $self->{_com_lock} = undef; $self->{_dat_lock} = undef; return; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Core::Worker - Core methods for the worker process =head1 VERSION This document describes MCE::Core::Worker version 1.901 =head1 DESCRIPTION This package provides main, loop, and relevant methods used internally by the worker process. There is no public API. =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Core/Input/000755 000765 000024 00000000000 14735611252 015551 5ustar00mariostaff000000 000000 MCE-1.901/lib/MCE/Core/Validation.pm000644 000765 000024 00000027712 14735610752 017117 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## 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.901'; ## 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}); } for my $_k (qw(job_delay spawn_delay submit_delay loop_timeout)) { _croak("$_tag: ($_k) is not valid") if ($_s->{$_k} && (!looks_like_number($_s->{$_k}) || $_s->{$_k} < 0)); } for my $_k (qw(freeze thaw on_post_exit on_post_run user_error user_output)) { _croak("$_tag: ($_k) is not a CODE reference") if ($_s->{$_k} && ref $_s->{$_k} ne 'CODE'); } _validate_args_s($_s); if (defined $_s->{user_tasks}) { for my $_t (@{ $_s->{user_tasks} }) { _validate_args_s($_s, $_t); } } 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[0-9e\+]+\z/ or $_s->{chunk_size} == 0); $_s->{chunk_size} = int($_s->{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/); for my $_k (qw(progress user_begin user_end user_func task_end)) { _croak("$_tag: ($_k) is not a CODE reference") if ($_s->{$_k} && ref $_s->{$_k} 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'); } for my $_k (qw(begin end)) { _croak("$_tag: ($_k) is not defined for sequence") unless (defined $_seq->{$_k}); } 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 (ref $_s->{sequence} eq 'HASH') { for my $_k ('begin', 'end', 'step') { $_s->{sequence}{$_k} = int($_s->{sequence}{$_k}) unless ($_s->{sequence}{$_k} =~ /\./); } } else { for my $_i (0, 1, 2) { $_s->{sequence}[$_i] = int($_s->{sequence}[$_i]) unless ($_s->{sequence}[$_i] =~ /\./); } } 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} = MCE::Util::_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; } ############################################################################### ## ---------------------------------------------------------------------------- ## Private functions for MCE Models { Flow, Grep, Loop, Map, Step, Stream }. ## ############################################################################### 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 greater. # # sub make_iter { # ... # return sub { # my ($chunk_size) = @_; # ... # }; # } return 1; } my $_is_file; my $_size = $_array_size; if (defined $_input_data) { if (ref $_input_data eq 'ARRAY') { $_size = scalar @{ $_input_data }; } elsif (ref $_input_data eq 'HASH') { $_size = scalar keys %{ $_input_data }; } } 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 if ($_chunk_size <= 8192) { $_chunk_size = (caller() =~ /^MCE::(?:Grep|Map|Stream)/) ? 1 : 2; } } } else { $_chunk_size = int($_size / $_max_workers / 24 + 0.5); $_chunk_size = 8000 if $_chunk_size > 8000; if ($_chunk_size < 2) { $_chunk_size = (caller() =~ /^MCE::(?:Grep|Map|Stream)/) ? 1 : 2; } } } return $_chunk_size; } 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 = MCE::Util::get_ncpu(); $_ncpu_ul = 8 if ($_ncpu_ul > 8); if (defined($1) && defined($2)) { local $@; $_max_workers = eval "int($_ncpu_ul $1 $2 + 0.5)"; ## no critic $_max_workers = 1 if (!$_max_workers || $_max_workers < 1); $_max_workers = $_ncpu if ($_max_workers > $_ncpu); } else { $_max_workers = $_ncpu_ul; } } elsif ($_max_workers =~ /^([0-9.]+)%$/) { my $_percent = $1 / 100; my $_ncpu = MCE::Util::get_ncpu(); $_max_workers = int($_ncpu * $_percent + 0.5); $_max_workers = 1 if ($_max_workers < 1); } return $_max_workers; } sub _validate_number { my ($_n, $_key, $_tag) = @_; _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::Core::Validation - Core validation methods for Many-Core Engine =head1 VERSION This document describes MCE::Core::Validation version 1.901 =head1 DESCRIPTION This package provides validation methods used internally by the manager process. There is no public API. =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Core/Manager.pm000644 000765 000024 00000075746 14735610752 016411 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## 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.901'; ## 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 ); ## The POSIX module has many symbols. Try not loading it simply ## to have WNOHANG. The following covers most platforms. use constant { _WNOHANG => ( $INC{'POSIX.pm'} ) ? &POSIX::WNOHANG : ( $^O eq 'solaris' ) ? 64 : 1 }; ############################################################################### ## ---------------------------------------------------------------------------- ## 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); } } elsif (defined $self->{task_end}) { $self->{task_end}->($self, 0, $self->{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. ## ############################################################################### my %_sendto_fhs; sub _sendto_fhs_close { for my $_p (keys %_sendto_fhs) { close $_sendto_fhs{$_p}; delete $_sendto_fhs{$_p}; } } sub _sendto_fhs_get { my ($self, $_fd) = @_; $_sendto_fhs{$_fd} || do { $_sendto_fhs{$_fd} = IO::Handle->new(); $_sendto_fhs{$_fd}->fdopen($_fd, 'w') or _croak "Cannot open file descriptor ($_fd): $!"; binmode $_sendto_fhs{$_fd}; if (!exists $self->{flush_file} || $self->{flush_file}) { local $!; $_sendto_fhs{$_fd}->autoflush(1) } $_sendto_fhs{$_fd}; }; } 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, $_win32_ipc, $_cb, $_chunk_id, $_chunk_size, $_file, $_size_completed, $_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, $_BSB_R_SOCK, $_DAT_R_SOCK, $_DAU_R_SOCK, $_MCE_STDERR, $_I_FLG, $_O_FLG, $_I_SEP, $_O_SEP, $_RS, $_RS_FLG, $_MCE_STDOUT, @_delay_wid ); ## ------------------------------------------------------------------------- ## Callback return. my $_cb_reply = sub { local $\ = $_O_SEP if ($_O_FLG); local $/ = $_I_SEP if ($_I_FLG); no strict 'refs'; if ( $_wa == WANTS_UNDEF ) { $_cb->(@_); return; } elsif ( $_wa == WANTS_ARRAY ) { my @_ret = $_cb->(@_); my $_buf = $self->{freeze}(\@_ret); return print {$_DAU_R_SOCK} length($_buf).$LF, $_buf; } my $_ret = $_cb->(@_); my $_buf = $self->{freeze}([ $_ret ]); return print {$_DAU_R_SOCK} length($_buf).$LF, $_buf; }; ## ------------------------------------------------------------------------- ## 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 my $_i (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 my $_i (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. local ($!, $?); 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) { eval { $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); $self->{_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 }, $self->{_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_REF.$LF => sub { # Input << Array ref 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 = $self->{freeze}( [ $_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_G_REF.$LF => sub { # Input << Glob ref 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->can('getline') ? $_input_glob->getline : <$_input_glob>; $_eof_flag = 1 unless (length $_buf); } else { my $_last_len = 0; for (1 .. $_chunk_size) { $_buf .= $_input_glob->can('getline') ? $_input_glob->getline : <$_input_glob>; $_len = length $_buf; if ($_len == $_last_len) { $_eof_flag = 1; last; } $_last_len = $_len; } } } else { if ($_input_glob->can('getline') && $_input_glob->can('read')) { if ($_input_glob->read($_buf, $_chunk_size) == $_chunk_size) { $_buf .= $_input_glob->getline; $_eof_flag = 1 if (length $_buf == $_chunk_size); } else { $_eof_flag = 1; } } 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) { my $_tmp = $self->{freeze}(\$_buf); print {$_DAU_R_SOCK} length($_tmp).$LF . (++$_chunk_id).$LF, $_tmp; } else { print {$_DAU_R_SOCK} '0'.$LF; } return; }, OUTPUT_H_REF.$LF => sub { # Input << Hash ref my @_pairs; if ($_offset_pos >= $_input_size || $_aborted) { local $\ = undef if (defined $\); print {$_DAU_R_SOCK} '0'.$LF; return; } if ($_offset_pos + $_chunk_size - 1 < $_input_size) { for my $_i ($_offset_pos .. $_offset_pos + $_chunk_size - 1) { push @_pairs, each %{ $_input_data }; } } else { for my $_i ($_offset_pos .. $_input_size - 1) { push @_pairs, each %{ $_input_data }; } } my $_buf = $self->{freeze}(\@_pairs); $_len = length $_buf; local $\ = undef if (defined $\); print {$_DAU_R_SOCK} $_len.$LF . (++$_chunk_id).$LF, $_buf; $_offset_pos += $_chunk_size; return; }, OUTPUT_I_REF.$LF => sub { # Input << Iter ref my $_buf; if ($_aborted) { local $\ = undef if (defined $\); print {$_DAU_R_SOCK} '-1'.$LF; return; } my @_ret_a = $_input_data->($_chunk_size); if (@_ret_a > 1 || defined $_ret_a[0]) { $_buf = $self->{freeze}([ @_ret_a ]); $_len = length $_buf; local $\ = undef if (defined $\); print {$_DAU_R_SOCK} $_len.$LF . (++$_chunk_id).$LF, $_buf; return; } local $\ = undef if (defined $\); print {$_DAU_R_SOCK} '-1'.$LF; $_aborted = 1; return; }, ## ---------------------------------------------------------------------- OUTPUT_A_CBK.$LF => sub { # Callback w/ args chomp($_wa = <$_DAU_R_SOCK>), chomp($_cb = <$_DAU_R_SOCK>), chomp($_len = <$_DAU_R_SOCK>); read $_DAU_R_SOCK, my($_buf), $_len; my $_aref = $self->{thaw}($_buf); undef $_buf; return $_cb_reply->(@{ $_aref }); }, OUTPUT_N_CBK.$LF => sub { # Callback w/ no args chomp($_wa = <$_DAU_R_SOCK>), chomp($_cb = <$_DAU_R_SOCK>); return $_cb_reply->(); }, OUTPUT_A_GTR.$LF => sub { # Gather data chomp($_task_id = <$_DAU_R_SOCK>), chomp($_len = <$_DAU_R_SOCK>); read $_DAU_R_SOCK, my($_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_O_SND.$LF => sub { # Send >> STDOUT chomp($_len = <$_DAU_R_SOCK>); read $_DAU_R_SOCK, my($_buf), $_len; $_buf = ${ $self->{thaw}($_buf) }; if (defined $_user_output) { $_user_output->($_buf); } else { use bytes; print {$_MCE_STDOUT} $_buf; } return; }, OUTPUT_E_SND.$LF => sub { # Send >> STDERR chomp($_len = <$_DAU_R_SOCK>); read $_DAU_R_SOCK, my($_buf), $_len; $_buf = ${ $self->{thaw}($_buf) }; if (defined $_user_error) { $_user_error->($_buf); } else { use bytes; print {$_MCE_STDERR} $_buf; } return; }, OUTPUT_F_SND.$LF => sub { # Send >> File my ($_buf, $_OUT_FILE); chomp($_len = <$_DAU_R_SOCK>); read $_DAU_R_SOCK, $_buf, $_len; $_buf = $self->{thaw}($_buf); $_file = $_buf->[0]; unless (exists $_sendto_fhs{$_file}) { open $_sendto_fhs{$_file}, ">>", "$_file" or _croak "Cannot open file for writing ($_file): $!"; binmode $_sendto_fhs{$_file}; if (!exists $self->{flush_file} || $self->{flush_file}) { local $!; $_sendto_fhs{$_file}->autoflush(1); } } { use bytes; $_OUT_FILE = $_sendto_fhs{$_file}; print {$_OUT_FILE} $_buf->[1]; } return; }, OUTPUT_D_SND.$LF => sub { # Send >> File descriptor my ($_buf, $_OUT_FILE); chomp($_len = <$_DAU_R_SOCK>); read $_DAU_R_SOCK, $_buf, $_len; $_buf = $self->{thaw}($_buf); { use bytes; $_OUT_FILE = _sendto_fhs_get($self, $_buf->[0]); print {$_OUT_FILE} $_buf->[1]; } 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 my $_i (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 my $_i (1 .. $_total_running) { syswrite($_BSB_R_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; }, OUTPUT_C_NFY.$LF => sub { # Chunk ID notification chomp($_len = <$_DAU_R_SOCK>); my ($_pid, $_chunk_id) = split /:/, $_len; $self->{_pids_c}{$_pid} = $_chunk_id; return; }, OUTPUT_P_NFY.$LF => sub { # Progress notification chomp($_len = <$_DAU_R_SOCK>); $self->{progress}->( $_size_completed += $_len ); return; }, OUTPUT_S_DIR.$LF => sub { # Make/get sess_dir print {$_DAU_R_SOCK} $self->sess_dir().$LF; return; }, OUTPUT_T_DIR.$LF => sub { # Make/get tmp_dir print {$_DAU_R_SOCK} $self->tmp_dir().$LF; return; }, OUTPUT_I_DLY.$LF => sub { # Interval delay my $_tasks = $_has_user_tasks ? $self->{user_tasks} : undef; chomp($_task_id = <$_DAU_R_SOCK>); my $_interval = ($_tasks && exists $_tasks->[$_task_id]{interval}) ? $_tasks->[$_task_id]{interval} : $self->{interval}; if (!$_interval) { print {$_DAU_R_SOCK} '0'.$LF; } elsif ($_interval->{max_nodes} == 1) { my $_delay = $_interval->{delay}; my $_lapse = $_interval->{_lapse}; my $_time = MCE::Util::_time(); if (!$_delay || !defined $_lapse) { $_lapse = $_time; } elsif ($_lapse + $_delay - $_time < 0) { $_lapse += int( abs($_time - $_lapse) / $_delay + 0.5 ) * $_delay; } $_interval->{_lapse} = ($_lapse += $_delay); print {$_DAU_R_SOCK} ($_lapse - $_time).$LF } else { my $_max_workers = ($_tasks) ? $_tasks->[$_task_id]{max_workers} : $self->{max_workers}; if (++$_delay_wid[$_task_id] > $_max_workers) { $_delay_wid[$_task_id] = 1; } my $_nodes = $_interval->{max_nodes}; my $_id = $_interval->{node_id}; my $_delay = $_interval->{delay} * $_nodes; my $_app_tb = $_delay * $_max_workers; my $_app_st = $_interval->{_time} + ($_delay / $_nodes * $_id); my $_wrk_st = ($_delay_wid[$_task_id] - 1) * $_delay + $_app_st; $_delay = $_wrk_st - MCE::Util::_time(); if ($_delay < 0.0 && $_app_tb) { my $_count = int($_delay * -1 / $_app_tb + 0.5) + 1; $_delay += $_app_tb * $_count; $_interval->{_time} = MCE::Util::_time() if ($_count > 2e9); } ($_delay > 0.0) ? print {$_DAU_R_SOCK} $_delay.$LF : print {$_DAU_R_SOCK} '0'.$LF; } return; }, ); ## ------------------------------------------------------------------------- local ($!, $?, $_); $_aborted = $_chunk_id = $_eof_flag = $_size_completed = 0; $_has_user_tasks = (defined $self->{user_tasks}) ? 1 : 0; $_cs_one_flag = ($self->{chunk_size} == 1) ? 1 : 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}; $_user_output = $self->{user_output}; $_user_error = $self->{user_error}; $_single_dim = $self->{_single_dim}; $_sess_dir = $self->{_sess_dir}; if (defined $_max_retries && !$_on_post_exit) { $_on_post_exit = sub { my ($self, $_e, $_retry_cnt) = @_; if ($_e->{id}) { my $_cnt = $_retry_cnt + 1; my $_msg = "Error: chunk $_e->{id} failed"; if (defined $self->{init_relay}) { print {*STDERR} "$_msg, retrying chunk attempt # $_cnt\n" if ($_retry_cnt < $_max_retries); } else { ($_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; } elsif (defined $_input_data && ref $_input_data eq 'HASH') { $_input_size = scalar( keys %{ $_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; } if (defined $self->{stderr_file}) { open $_MCE_STDERR, '>>', $self->{stderr_file} or die $self->{stderr_file} . ": $!\n"; binmode $_MCE_STDERR; } else { $_MCE_STDERR = \*STDERR; } ## Autoflush STDERR-STDOUT handles if not specified or requested. { local $!; $_MCE_STDERR->autoflush(1) if ( !exists $self->{flush_stderr} || $self->{flush_stderr} ); $_MCE_STDOUT->autoflush(1) if ( !exists $self->{flush_stdout} || $self->{flush_stdout} ); } ## ------------------------------------------------------------------------- ## Output event loop. my $_channels = $self->{_dat_r_sock}; my $_func; $_win32_ipc = ( $ENV{'PERL_MCE_IPC'} eq 'win32' || defined($self->{max_retries}) || $INC{'MCE/Child.pm'} || $INC{'MCE/Hobo.pm'} ); $_BSB_W_SOCK = $self->{_bsb_w_sock}; $_BSB_R_SOCK = $self->{_bsb_r_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]); $self->{_pids_c} = {}; # Chunk ID notification $_timeout = 5 if $_timeout < 5; local $SIG{ALRM} = sub { alarm 0; local ($!, $?); for my $i (0 .. @{ $_list }) { if ($_pid = $_list->[$i]) { if (waitpid($_pid, _WNOHANG)) { $_list->[$i] = undef; if ($? > abs($self->{_wrk_status})) { $self->{_wrk_status} = $?; } my $_task_id = $self->{_pids_t}{$_pid}; my $_wid = $self->{_pids_w}{$_pid}; $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 my $_i (1 .. $_total_running) { syswrite($_BSB_W_SOCK, $LF); } undef $_syn_flag; } } _task_end($self, $_task_id) unless $_total_running; if (my $_cid = $self->{_pids_c}{$_pid}) { warn "Error: process $_pid has ended prematurely\n", "Error: chunk $_cid failed\n"; if ($_cid > $self->{_relayed}) { local $SIG{CHLD} = 'IGNORE'; my $_pid = fork; if (defined $_pid && $_pid == 0) { delete $self->{max_retries}; $self->{_chunk_id} = $_cid; $self->{_task_id} = $_task_id; $self->{_wid} = $_wid; eval 'MCE::relay'; CORE::kill('KILL', $$); CORE::exit(0); } } } delete $self->{_pids_c}{$_pid}; delete $self->{_pids_t}{$_pid}; delete $self->{_pids_w}{$_pid}; } } } print {$_DAT_W_SOCK} 'NOOP'.$LF . '0'.$LF; }; while ( $self->{_total_running} ) { alarm($_timeout); $_func = <$_DAT_R_SOCK>, alarm(0); $_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}(); } } delete $self->{_pids_c}; } ## Wait on requests *without* timeout capability. elsif ($^O eq 'MSWin32') { MCE::Util::_nonblocking($_DAT_R_SOCK, 1) if $_win32_ipc; while ($self->{_total_running}) { MCE::Util::_sysread2($_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}(); } } MCE::Util::_nonblocking($_DAT_R_SOCK, 0) if $_win32_ipc; } 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. _sendto_fhs_close(); ## Close MCE STDOUT/STDERR handles. eval q{ close $_MCE_STDOUT if (fileno $_MCE_STDOUT > 2); close $_MCE_STDERR if (fileno $_MCE_STDERR > 2); }; return; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Core::Manager - Core methods for the manager process =head1 VERSION This document describes MCE::Core::Manager version 1.901 =head1 DESCRIPTION This package provides the loop and relevant methods used internally by the manager process. There is no public API. =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Core/Input/Sequence.pm000644 000765 000024 00000016407 14735610752 017673 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## 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.901'; ## 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 $_is_MSWin32 = ($^O eq 'MSWin32') ? 1 : 0; 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 ($_DAT_LOCK, $_dat_ex, $_dat_un, $_pid, $_abort, $_offset); $_pid = $INC{'threads.pm'} ? $$ .'.'. threads->tid() : $$; # inlined for performance $_DAT_LOCK = $self->{'_mutex_'.( $self->{_wid} % 2 + 10 )}; $_dat_ex = sub { CORE::lock($_DAT_LOCK->{_t_lock}), MCE::Util::_sock_ready($_DAT_LOCK->{_r_sock}) if $_is_MSWin32; MCE::Util::_sysread($_DAT_LOCK->{_r_sock}, my($b), 1), $_DAT_LOCK->{ $_pid } = 1 unless $_DAT_LOCK->{ $_pid }; }; $_dat_un = sub { syswrite($_DAT_LOCK->{_w_sock}, '0'), $_DAT_LOCK->{ $_pid } = 0 if $_DAT_LOCK->{ $_pid }; }; 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. $_dat_ex->(); MCE::Util::_sock_ready($_QUE_R_SOCK) if $_is_MSWin32; MCE::Util::_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)); $_dat_un->(); return; } syswrite( $_QUE_W_SOCK, pack($_que_template, $_chunk_id + 1, $_offset + 1) ); $_dat_un->(); $_chunk_id++; ## Call user function. if ($_chunk_size == 1 || $_begin == $_end) { $_ = $_offset * $_step + $_begin; $_ = _sprintf("%$_fmt", $_) if (defined $_fmt); if ($_chunk_size > 1 || $_bounds_only) { $_ = ($_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; } elsif ($_step == 1) { $_tmp_e = $_end; } 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; } elsif ($_step == -1) { $_tmp_e = $_end; } 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 && abs($_end) < ~1 && abs($_begin) < ~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; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Core::Input::Sequence - Sequence of numbers (for task_id == 0) =head1 VERSION This document describes MCE::Core::Input::Sequence version 1.901 =head1 DESCRIPTION This package provides a sequence of numbers used internally by the worker process. Distribution follows a bank-queuing model. There is no public API. =head1 SEE ALSO The syntax for the C option is described in L. =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Core/Input/Handle.pm000644 000765 000024 00000020742 14735610752 017313 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## File path and Scalar reference 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.901'; ## 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 -- Read handle. ## ############################################################################### sub _systell { # To minimize memory consumption, SEEK_CUR equals 1 on most platforms. # e.g. use Fcntl qw(SEEK_CUR); sysseek($_[0], 0, 1); } 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 $_is_MSWin32 = ($^O eq 'MSWin32') ? 1 : 0; 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 $_wuf = $self->{_wuf}; my ($_data_size, $_next, $_chunk_id, $_offset_pos, $_IN_FILE, $_tmp_cs); my ($_DAT_LOCK, $_dat_ex, $_dat_un, $_pid, $_chop_len, $_chop_str, $_p); $_pid = $INC{'threads.pm'} ? $$ .'.'. threads->tid() : $$; # inlined for performance $_DAT_LOCK = $self->{'_mutex_'.( $self->{_wid} % 2 + 10 )}; $_dat_ex = sub { CORE::lock($_DAT_LOCK->{_t_lock}), MCE::Util::_sock_ready($_DAT_LOCK->{_r_sock}) if $_is_MSWin32; MCE::Util::_sysread($_DAT_LOCK->{_r_sock}, my($b), 1), $_DAT_LOCK->{ $_pid } = 1 unless $_DAT_LOCK->{ $_pid }; }; $_dat_un = sub { syswrite($_DAT_LOCK->{_w_sock}, '0'), $_DAT_LOCK->{ $_pid } = 0 if $_DAT_LOCK->{ $_pid }; }; 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_GC_SIZE); $_ = ''; ## Obtain the next chunk_id and offset position. $_dat_ex->(); MCE::Util::_sock_ready($_QUE_R_SOCK) if $_is_MSWin32; MCE::Util::_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)); $_dat_un->(); 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 ($/ ne $_RS); 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) ); $_dat_un->(); } else { # Large chunk. local $/ = $_RS if ($/ ne $_RS); if ($_parallel_io && $_RS eq $LF) { syswrite( $_QUE_W_SOCK, pack($_que_template, $_chunk_id, $_offset_pos + $_chunk_size) ); $_dat_un->(); $_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) ); $_dat_un->(); } } ## 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 ($/ ne $_RS); _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; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Core::Input::Handle - File path and Scalar reference input reader =head1 VERSION This document describes MCE::Core::Input::Handle version 1.901 =head1 DESCRIPTION This package provides the read handle method used internally by the worker process. Distribution follows a bank-queuing model. There is no public API. =head1 SEE ALSO The syntax for the C option is described in L. =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Core/Input/Request.pm000644 000765 000024 00000014174 14735610752 017552 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## Array reference and Glob reference 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.901'; ## Items below are folded into MCE. package # hide from rpm MCE; no warnings qw( threads recursion uninitialized ); ############################################################################### ## ---------------------------------------------------------------------------- ## 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 $_is_MSWin32 = ($^O eq 'MSWin32') ? 1 : 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}; my $_chunk_size = $self->{chunk_size}; my $_use_slurpio = $self->{use_slurpio}; my $_RS = $self->{RS} || $/; my $_wuf = $self->{_wuf}; my ($_dat_ex, $_dat_un, $_pid); if ($_lock_chn) { $_pid = $INC{'threads.pm'} ? $$ .'.'. threads->tid() : $$; # inlined for performance $_dat_ex = sub { CORE::lock($_DAT_LOCK->{_t_lock}), MCE::Util::_sock_ready($_DAT_LOCK->{_r_sock}) if $_is_MSWin32; MCE::Util::_sysread($_DAT_LOCK->{_r_sock}, my($b), 1), $_DAT_LOCK->{ $_pid } = 1 unless $_DAT_LOCK->{ $_pid }; }; $_dat_un = sub { syswrite($_DAT_LOCK->{_w_sock}, '0'), $_DAT_LOCK->{ $_pid } = 0 if $_DAT_LOCK->{ $_pid }; }; } my ($_chunk_id, $_len, $_output_tag); my ($_chop_len, $_chop_str, $_p); if ($_proc_type == REQUEST_ARRAY) { $_output_tag = OUTPUT_A_REF; $_chop_len = 0; } elsif ($_proc_type == REQUEST_HASH) { $_output_tag = OUTPUT_H_REF; $_chop_len = 0; } else { $_output_tag = OUTPUT_G_REF; 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_GC_SIZE); $_ = ''; ## Obtain the next chunk of data. { local $\ = undef if (defined $\); local $/ = $LF if ($/ ne $LF ); $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} $_output_tag . $LF . $_chn . $LF; MCE::Util::_sock_ready($_DAU_W_SOCK, -1) if $_is_MSWin32; 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) { my $_chunk_ref = $self->{thaw}($_); undef $_; $_ = ($_chunk_size == 1) ? $_chunk_ref->[0] : $_chunk_ref; $_wuf->($self, $_chunk_ref, $_chunk_id); } elsif ($_proc_type == REQUEST_HASH) { my $_chunk_ref = { @{ $self->{thaw}($_) } }; undef $_; $_ = $_chunk_ref; $_wuf->($self, $_chunk_ref, $_chunk_id); } else { $_ = ${ $self->{thaw}($_) }; 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 ($/ ne $_RS); _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; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Core::Input::Request - Array reference and Glob reference input reader =head1 VERSION This document describes MCE::Core::Input::Request version 1.901 =head1 DESCRIPTION This package provides the request chunk method used internally by the worker process. Distribution follows a bank-queuing model. There is no public API. =head1 SEE ALSO The syntax for the C option is described in L. =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Core/Input/Iterator.pm000644 000765 000024 00000007602 14735610752 017711 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## Iterator reader. ## ## This package, used internally 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.901'; ## Items below are folded into MCE. package # hide from rpm MCE; no warnings qw( threads recursion uninitialized ); ############################################################################### ## ---------------------------------------------------------------------------- ## 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 $_is_MSWin32 = ($^O eq 'MSWin32') ? 1 : 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}; my $_chunk_size = $self->{chunk_size}; my $_wuf = $self->{_wuf}; my ($_dat_ex, $_dat_un, $_pid); if ($_lock_chn) { $_pid = $INC{'threads.pm'} ? $$ .'.'. threads->tid() : $$; # inlined for performance $_dat_ex = sub { CORE::lock($_DAT_LOCK->{_t_lock}), MCE::Util::_sock_ready($_DAT_LOCK->{_r_sock}) if $_is_MSWin32; MCE::Util::_sysread($_DAT_LOCK->{_r_sock}, my($b), 1), $_DAT_LOCK->{ $_pid } = 1 unless $_DAT_LOCK->{ $_pid }; }; $_dat_un = sub { syswrite($_DAT_LOCK->{_w_sock}, '0'), $_DAT_LOCK->{ $_pid } = 0 if $_DAT_LOCK->{ $_pid }; }; } my ($_chunk_id, $_len); ## ------------------------------------------------------------------------- $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_GC_SIZE); $_ = ''; ## Obtain the next chunk of data. { local $\ = undef if (defined $\); local $/ = $LF if ($/ ne $LF ); $_dat_ex->() if $_lock_chn; print {$_DAT_W_SOCK} OUTPUT_I_REF . $LF . $_chn . $LF; MCE::Util::_sock_ready($_DAU_W_SOCK, -1) if $_is_MSWin32; chomp($_len = <$_DAU_W_SOCK>); if ($_len < 0) { $_dat_un->() if $_lock_chn; return; } chomp($_chunk_id = <$_DAU_W_SOCK>); read $_DAU_W_SOCK, $_, $_len; $_dat_un->() if $_lock_chn; } ## Call user function. my $_chunk_ref = $self->{thaw}($_); undef $_; $_ = ($_chunk_size == 1) ? $_chunk_ref->[0] : $_chunk_ref; $_wuf->($self, $_chunk_ref, $_chunk_id); } _WORKER_USER_ITERATOR__LAST: return; } 1; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Core::Input::Iterator - Iterator reader =head1 VERSION This document describes MCE::Core::Input::Iterator version 1.901 =head1 DESCRIPTION This package, used internally by the worker process, provides support for user specified iterators assigned to C. There is no public API. =head1 SEE ALSO The syntax for the C option is described in L. =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/lib/MCE/Core/Input/Generator.pm000644 000765 000024 00000015675 14735610752 020057 0ustar00mariostaff000000 000000 ############################################################################### ## ---------------------------------------------------------------------------- ## 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.901'; ## 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; } elsif ($_step == 1) { $_tmp_e = $_end if ($_next <= $_end); } 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; } elsif ($_step == -1) { $_tmp_e = $_end if ($_next >= $_end); } 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 && abs($_end) < ~1 && abs($_begin) < ~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; __END__ ############################################################################### ## ---------------------------------------------------------------------------- ## Module usage. ## ############################################################################### =head1 NAME MCE::Core::Input::Generator - Sequence of numbers (for task_id > 0) =head1 VERSION This document describes MCE::Core::Input::Generator version 1.901 =head1 DESCRIPTION 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. =head1 SEE ALSO The syntax for the C option is described in L. =head1 AUTHOR Mario E. Roy, Smarioeroy AT gmail DOT comE> =cut MCE-1.901/xt/dequeue_timed.t000644 000765 000024 00000004673 14437657371 016074 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE'; use_ok 'MCE::Flow'; use_ok 'MCE::Queue'; } my @a = (); my $q = MCE::Queue->new( queue => \@a ); sub check_enqueue { my ($description) = @_; is( join('', @a), '12345', $description ); } sub check_dequeue_nb { my ($description, $value) = @_; is( $value, '12345', $description ); is( join('', @a), '', 'queue emptied' ); } sub check_dequeue_timed { my ($description, $success) = @_; is( $success, 1, $description ); } ## Manager tests { $q->enqueue('12345'); check_enqueue('manager: check enqueue'); check_dequeue_nb('manager: check dequeue_nb', $q->dequeue_timed); my $start = MCE::Util::_time(); my $ret = $q->dequeue_timed(2.0); # no timed support for the manager process my $success = (!$ret && MCE::Util::_time() - $start < 1.0) ? 1 : 0; check_dequeue_timed('manager: check dequeue_timed', $success); } ## Worker tests MCE::Flow->init( max_workers => 1 ); mce_flow sub { my ($mce) = @_; $q->enqueue('12345'); MCE->do('check_enqueue', 'worker: check enqueue'); MCE->do('check_dequeue_nb', 'worker: check dequeue_nb', $q->dequeue_timed); my $start = MCE::Util::_time(); my $ret = $q->dequeue_timed(2.0); my $success = (!$ret && MCE::Util::_time() - $start > 1.0) ? 1 : 0; MCE->do('check_dequeue_timed', 'worker: check dequeue_timed', $success); return; }; MCE::Flow->finish; ## Parallel demo my $s = MCE::Util::_time(); my @r; MCE->new( user_tasks => [{ # consumers max_workers => 8, chunk_size => 1, sequence => [ 1, 40 ], gather => \@r, user_func => sub { # each worker calls dequeue_timed approximately 5 times if (defined(my $ret = $q->dequeue_timed(1.0))) { MCE->printf("$ret: time %0.3f, pid $$\n", MCE::Util::_time()); MCE->gather($ret); } } },{ # provider max_workers => 1, user_func => sub { $q->enqueue($_) for 'a'..'d'; sleep 1; $q->enqueue('e'); sleep 1; $q->enqueue('f'); sleep 1; $q->enqueue('g'); } }] )->run; my $duration = MCE::Util::_time() - $s; printf "%0.3f seconds\n", $duration; my $success = (abs(5.0 - $duration) < 2.0) ? 1 : 0; is( $success, 1, 'parallel demo duration' ); is( scalar(@r), 7, 'gathered size' ); is( join('', sort @r), 'abcdefg', 'gathered data' ); done_testing; MCE-1.901/xt/flock_lock.t000644 000765 000024 00000001305 14500402753 015327 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More; use Time::HiRes 'time'; use MCE::Mutex; my $mutex = MCE::Mutex->new( impl => 'Flock' ); is($mutex->impl(), 'Flock', 'implementation name'); sub task1 { $mutex->lock_exclusive; sleep 1; $mutex->unlock; } sub task2 { my $guard = $mutex->guard_lock; sleep 1; } sub spawn { my ($i) = @_; my $pid = fork; if ($pid == 0) { task1() if ($i % 2 != 0); task2() if ($i % 2 == 0); exit(); } return $pid; } my $start = time; my @pids = map { spawn($_) } 1..4; waitpid($_, 0) for @pids; my $success = (time - $start > 2) ? 1 : 0; is($success, 1, 'mutex lock_exclusive'); done_testing; MCE-1.901/xt/channel_timedwait.t000644 000765 000024 00000001170 14436121552 016703 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More; use Time::HiRes 'time'; use MCE::Mutex; my $mutex = MCE::Mutex->new( impl => 'Channel' ); is($mutex->impl(), 'Channel', 'implementation name'); sub task { $mutex->lock_exclusive; sleep(1) for 1..5; $mutex->unlock; } sub spawn { my $pid = fork; task(), exit() if $pid == 0; return $pid; } my $pid = spawn(); sleep 1; my $start = time; my $ret = $mutex->timedwait(2); my $end = time; waitpid($pid, 0); my $success = ($end - $start < 3) ? 1 : 0; is($success, 1, 'mutex timedwait'); is($ret, '', 'mutex timedwait value'); done_testing; MCE-1.901/xt/channel2_lock.t000644 000765 000024 00000002116 14500410012 015707 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More; use Time::HiRes 'time'; use MCE::Mutex; my $mutex = MCE::Mutex->new( impl => 'Channel2' ); is($mutex->impl(), 'Channel2', 'implementation name'); sub task1a { $mutex->lock_exclusive; sleep(1) for 1..2; $mutex->unlock; } sub task1b { my $guard = $mutex->guard_lock; sleep(1) for 1..2; } sub spawn1 { my ($i) = @_; my $pid = fork; if ($pid == 0) { task1a() if ($i % 2 != 0); task1b() if ($i % 2 == 0); exit(); } return $pid; } sub task2a { $mutex->lock_exclusive2; sleep(1) for 1..2; $mutex->unlock2; } sub task2b { my $guard = $mutex->guard_lock2; sleep(1) for 1..2; } sub spawn2 { my ($i) = @_; my $pid = fork; if ($pid == 0) { task2a() if ($i % 2 != 0); task2b() if ($i % 2 == 0); exit(); } return $pid; } my $start = time; my @pids = map { spawn1($_), spawn2($_) } 1..3; waitpid($_, 0) for @pids; my $success = (time - $start > 3) ? 1 : 0; is($success, 1, 'mutex lock_exclusive2'); done_testing; MCE-1.901/xt/nonblocking_queue.t000644 000765 000024 00000002723 14355563354 016752 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use utf8; use open qw(:std :utf8); use Test::More; # Non-blocking tests (dequeue_nb and recv_nb) were disabled # in MCE 1.884 for the Windows platform; copied here in xt. # The following tests pass on Windows, typically. BEGIN { use_ok 'MCE::Flow'; use_ok 'MCE::Queue'; } MCE::Flow->init( max_workers => 1 ); # https://sacred-texts.com/cla/usappho/sph02.htm (VI) my $sappho_text = "καὶ γάρ αἰ φεύγει, ταχέωσ διώξει, αἰ δὲ δῶρα μὴ δέκετ ἀλλά δώσει, αἰ δὲ μὴ φίλει ταχέωσ φιλήσει, κωὐκ ἐθέλοισα." . "Ǣ"; my $translation = "For if now she flees, quickly she shall follow And if she spurns gifts, soon shall she offer them Yea, if she knows not love, soon shall she feel it Even reluctant."; sub check_unicode_out { my ($description, $value) = @_; is( $value, $sappho_text, $description ); } # MCE::Queue provides 2 operating modes (manager and worker). # This will test (normal queue) by the manager process. my @a = (); my $q = MCE::Queue->new( queue => \@a ); $q->enqueue($sappho_text); is( $q->dequeue_nb, $sappho_text, 'check dequeue_nb - manager' ); # This will test (normal queue) by the MCE worker process. mce_flow sub { $q->enqueue($sappho_text); MCE->do('check_unicode_out', 'check dequeue_nb - worker', $q->dequeue_nb); return; }; MCE::Flow->finish; done_testing; MCE-1.901/xt/nonblocking_channel.t000644 000765 000024 00000012012 14355563370 017224 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use utf8; use open qw(:std :utf8); use Test::More; # Non-blocking tests (dequeue_nb and recv_nb) were disabled # in MCE 1.884 for the Windows platform; copied here in xt. # The following tests pass on Windows, typically. BEGIN { if ( $^O eq 'cygwin' ) { plan skip_all => "MCE::Channel::Threads not used on Cygwin"; } eval 'use threads'; ## no critic plan skip_all => "threads not available" if $@; use_ok 'MCE::Channel'; use_ok 'MCE::Channel::Simple'; use_ok 'MCE::Channel::SimpleFast'; use_ok 'MCE::Channel::Threads'; use_ok 'MCE::Channel::ThreadsFast'; } # https://sacred-texts.com/cla/usappho/sph02.htm (III) my $sappho_text = "ἄρμ᾽ ὐποζεύξαια, κάλοι δέ σ᾽ ἆγον ὤκεεσ στροῦθοι περὶ γᾶσ μελαίνασ πύκνα δινεῦντεσ πτέῤ ἀπ᾽ ὠράνω αἴθεροσ διὰ μέσσω."; my $translation = "With chariot yoked to thy fleet-winged coursers, Fluttering swift pinions over earth's darkness, And bringing thee through the infinite, gliding Downwards from heaven."; my $come_then_i_pray = "さあ、私は祈る" . "Ǣ"; my $chnl1 = MCE::Channel->new( impl => 'Simple' ); is $chnl1->impl(), 'Simple', 'implementation name'; my $chnl2 = MCE::Channel->new( impl => 'Threads' ); is $chnl2->impl(), 'Threads', 'implementation name'; my $chnl3 = MCE::Channel->new( impl => 'SimpleFast' ); is $chnl3->impl(), 'SimpleFast', 'implementation name'; my $chnl4 = MCE::Channel->new( impl => 'ThreadsFast' ); is $chnl4->impl(), 'ThreadsFast', 'implementation name'; # send recv_nb for my $chnl ($chnl1, $chnl2) { $chnl->send('a string'); is $chnl->recv_nb, 'a string', 'send recv_nb scalar'; $chnl->send($sappho_text); is $chnl->recv_nb, $sappho_text, 'send recv_nb utf8'; $chnl->send($come_then_i_pray); is $chnl->recv_nb, $come_then_i_pray, 'send recv_nb utf8_ja'; $chnl->send(qw/ a list of arguments /); is scalar( my @args = $chnl->recv_nb ), 4, 'send recv_nb list'; $chnl->send({ complex => 'structure' }); is ref( $chnl->recv_nb ), 'HASH', 'send recv_nb complex'; } for my $chnl ($chnl3, $chnl4) { $chnl->send('a string'); is $chnl->recv_nb, 'a string', 'send recv_nb scalar'; $chnl->send(''); is $chnl->recv_nb, '', 'send recv_nb blank string'; $chnl->send(undef); is $chnl->recv_nb, '', 'send recv_nb undef stringified'; } # send2 recv2_nb for my $chnl ($chnl1, $chnl2) { $chnl->send2('a string'); is $chnl->recv2_nb, 'a string', 'send2 recv2_nb scalar'; $chnl->send2($sappho_text); is $chnl->recv2_nb, $sappho_text, 'send2 recv2_nb utf8'; $chnl->send2($come_then_i_pray); is $chnl->recv2_nb, $come_then_i_pray, 'send2 recv2_nb utf8_ja'; $chnl->send2(qw/ a list of arguments /); is scalar( my @args = $chnl->recv2_nb ), 4, 'send2 recv2_nb list'; $chnl->send2({ complex => 'structure' }); is ref( $chnl->recv2_nb ), 'HASH', 'send2 recv2_nb complex'; } for my $chnl ($chnl3, $chnl4) { $chnl->send2('a string'); is $chnl->recv2_nb, 'a string', 'send2 recv2_nb scalar'; $chnl->send2(''); is $chnl->recv2_nb, '', 'send2 recv2_nb blank string'; $chnl->send2(undef); is $chnl->recv2_nb, '', 'send2 recv2_nb undef stringified'; } # enqueue dequeue_nb for my $chnl ($chnl1, $chnl2) { $chnl->enqueue('a string'); is $chnl->dequeue_nb, 'a string', 'enqueue dequeue_nb scalar'; $chnl->enqueue($sappho_text); is $chnl->dequeue_nb, $sappho_text, 'enqueue dequeue_nb utf8'; $chnl->enqueue($come_then_i_pray); is $chnl->dequeue_nb, $come_then_i_pray, 'enqueue dequeue_nb utf8_ja'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue_nb ), 'a', 'enqueue dequeue_nb item1'; is scalar( my $item2 = $chnl->dequeue_nb ), 'list', 'enqueue dequeue_nb item2'; is scalar( my $item3 = $chnl->dequeue_nb ), 'of', 'enqueue dequeue_nb item3'; is scalar( my $item4 = $chnl->dequeue_nb ), 'items', 'enqueue dequeue_nb item4'; $chnl->enqueue({ complex => 'structure' }); is ref( $chnl->dequeue_nb ), 'HASH', 'enqueue dequeue_nb complex'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue_nb(3) ), 'abc', 'enqueue dequeue_nb count'; } for my $chnl ($chnl3, $chnl4) { $chnl->enqueue('a string'); is $chnl->dequeue_nb, 'a string', 'enqueue dequeue_nb scalar'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue_nb ), 'a', 'enqueue dequeue_nb item1'; is scalar( my $item2 = $chnl->dequeue_nb ), 'list', 'enqueue dequeue_nb item2'; is scalar( my $item3 = $chnl->dequeue_nb ), 'of', 'enqueue dequeue_nb item3'; is scalar( my $item4 = $chnl->dequeue_nb ), 'items', 'enqueue dequeue_nb item4'; $chnl->enqueue(''); is $chnl->dequeue_nb, '', 'enqueue dequeue_nb blank string'; $chnl->enqueue(undef); is $chnl->dequeue_nb, '', 'enqueue dequeue_nb undef stringified'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue_nb(3) ), 'abc', 'enqueue dequeue_nb count'; } done_testing; MCE-1.901/xt/channel2_timedwait.t000644 000765 000024 00000002131 14436121532 016761 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More; use Time::HiRes 'time'; use MCE::Mutex; my $mutex = MCE::Mutex->new( impl => 'Channel2' ); is($mutex->impl(), 'Channel2', 'implementation name'); sub task { $mutex->lock_exclusive; sleep(1) for 1..5; $mutex->unlock; } sub task2 { $mutex->lock_exclusive2; sleep(1) for 1..5; $mutex->unlock2; } sub spawn { my $pid = fork; task(), exit() if $pid == 0; return $pid; } sub spawn2 { my $pid = fork; task2(), exit() if $pid == 0; return $pid; } { my $pid = spawn(); sleep 1; my $start = time; my $ret = $mutex->timedwait(2); my $end = time; waitpid($pid, 0); my $success = ($end - $start < 3) ? 1 : 0; is($success, 1, 'mutex timedwait'); is($ret, '', 'mutex timedwait value'); } { my $pid = spawn2(); sleep 1; my $start = time; my $ret = $mutex->timedwait2(2); my $end = time; waitpid($pid, 0); my $success = ($end - $start < 3) ? 1 : 0; is($success, 1, 'mutex timedwait2'); is($ret, '', 'mutex timedwait2 value'); } done_testing; MCE-1.901/xt/channel_lock.t000644 000765 000024 00000001335 14500402725 015643 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More; use Time::HiRes 'time'; use MCE::Mutex; my $mutex = MCE::Mutex->new( impl => 'Channel' ); is($mutex->impl(), 'Channel', 'implementation name'); sub task1 { $mutex->lock_exclusive; sleep(1) for 1..2; $mutex->unlock; } sub task2 { my $guard = $mutex->guard_lock; sleep(1) for 1..2; } sub spawn { my ($i) = @_; my $pid = fork; if ($pid == 0) { task1() if ($i % 2 != 0); task2() if ($i % 2 == 0); exit(); } return $pid; } my $start = time; my @pids = map { spawn($_) } 1..3; waitpid($_, 0) for @pids; my $success = (time - $start > 3) ? 1 : 0; is($success, 1, 'mutex lock_exclusive'); done_testing; MCE-1.901/t/05_mce_step.t000644 000765 000024 00000005066 13671470012 015145 0ustar00mariostaff000000 000000 #!/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 { gather => output_iterator(\@a) }, \&task_a, \&task_b, [ 1..9 ]; is( join(' ', @a), $answers, 'check results for array ref' ); 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; ## process hash, current API available since 1.828 MCE::Step->init( max_workers => 1 ); my %hash = map { $_ => $_ } ( 1 .. 9 ); my %res = mce_step sub { my ($mce, $chunk_ref, $chunk_id) = @_; my %ret; for my $key ( keys %{ $chunk_ref } ) { $ret{$key} = $chunk_ref->{$key} * 2; } MCE->gather(%ret); }, \%hash; @a = map { $res{$_} } ( 1 .. 9 ); is( join(' ', @a), "2 4 6 8 10 12 14 16 18", 'check results for hash ref' ); MCE::Step->finish; ## cleanup unlink $in_file; done_testing; __DATA__ 1 2 3 4 5 6 7 8 9 MCE-1.901/t/04_channel_threads.t000644 000765 000024 00000012644 14435464166 016503 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use utf8; use open qw(:std :utf8); use Test::More; BEGIN { plan skip_all => "Not used on Cygwin" if ( $^O eq 'cygwin' ); if ( $] lt '5.010001' && $^O ne 'MSWin32' ) { plan skip_all => "old Perl and threads not supported on Unix platforms"; } eval 'use threads'; ## no critic plan skip_all => "threads not available" if $@; use_ok 'MCE::Channel'; use_ok 'MCE::Channel::Threads'; } ## https://sacred-texts.com/cla/usappho/sph02.htm (V) my $sappho_text = "κὤττι μοι μάλιστα θέλω γένεσθαι μαινόλᾳ θύμῳ, τίνα δηὖτε πείθω μαῖσ ἄγην ἐσ σὰν φιλότατα τίσ τ, ὦ Πσάπφ᾽, ἀδίκηει;"; my $translation = "What in my mad heart was my greatest desire, Who was it now that must feel my allurements, Who was the fair one that must be persuaded, Who wronged thee Sappho?"; my $come_then_i_pray = "さあ、私は祈る" . "Ǣ"; my $chnl = MCE::Channel->new( impl => 'Threads' ); is $chnl->impl(), 'Threads', 'implementation name'; # send recv { $chnl->send('a string'); is $chnl->recv, 'a string', 'send recv scalar'; $chnl->send($sappho_text); is $chnl->recv, $sappho_text, 'send recv utf8'; $chnl->send($come_then_i_pray); is $chnl->recv, $come_then_i_pray, 'send recv utf8_ja'; $chnl->send(qw/ a list of arguments /); is scalar( my @args = $chnl->recv ), 4, 'send recv list'; $chnl->send({ complex => 'structure' }); is ref( $chnl->recv ), 'HASH', 'send recv complex'; } # send recv_nb if ($^O ne 'MSWin32') { $chnl->send('a string'); is $chnl->recv_nb, 'a string', 'send recv_nb scalar'; $chnl->send($sappho_text); is $chnl->recv_nb, $sappho_text, 'send recv_nb utf8'; $chnl->send($come_then_i_pray); is $chnl->recv_nb, $come_then_i_pray, 'send recv_nb utf8_ja'; $chnl->send(qw/ a list of arguments /); is scalar( my @args = $chnl->recv_nb ), 4, 'send recv_nb list'; $chnl->send({ complex => 'structure' }); is ref( $chnl->recv_nb ), 'HASH', 'send recv_nb complex'; } # send2 recv2 { $chnl->send2('a string'); is $chnl->recv2, 'a string', 'send2 recv2 scalar'; $chnl->send2($sappho_text); is $chnl->recv2, $sappho_text, 'send2 recv2 utf8'; $chnl->send2($come_then_i_pray); is $chnl->recv2, $come_then_i_pray, 'send2 recv2 utf8_ja'; $chnl->send2(qw/ a list of arguments /); is scalar( my @args = $chnl->recv2 ), 4, 'send2 recv2 list'; $chnl->send2({ complex => 'structure' }); is ref( $chnl->recv2 ), 'HASH', 'send2 recv2 complex'; } # send2 recv2_nb if ($^O ne 'MSWin32') { $chnl->send2('a string'); is $chnl->recv2_nb, 'a string', 'send2 recv2_nb scalar'; $chnl->send2($sappho_text); is $chnl->recv2_nb, $sappho_text, 'send2 recv2_nb utf8'; $chnl->send2($come_then_i_pray); is $chnl->recv2_nb, $come_then_i_pray, 'send2 recv2_nb utf8_ja'; $chnl->send2(qw/ a list of arguments /); is scalar( my @args = $chnl->recv2_nb ), 4, 'send2 recv2_nb list'; $chnl->send2({ complex => 'structure' }); is ref( $chnl->recv2_nb ), 'HASH', 'send2 recv2_nb complex'; } # enqueue dequeue { $chnl->enqueue('a string'); is $chnl->dequeue, 'a string', 'enqueue dequeue scalar'; $chnl->enqueue($sappho_text); is $chnl->dequeue, $sappho_text, 'enqueue dequeue utf8'; $chnl->enqueue($come_then_i_pray); is $chnl->dequeue, $come_then_i_pray, 'enqueue dequeue utf8_ja'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue ), 'a', 'enqueue dequeue item1'; is scalar( my $item2 = $chnl->dequeue ), 'list', 'enqueue dequeue item2'; is scalar( my $item3 = $chnl->dequeue ), 'of', 'enqueue dequeue item3'; is scalar( my $item4 = $chnl->dequeue ), 'items', 'enqueue dequeue item4'; $chnl->enqueue({ complex => 'structure' }); is ref( $chnl->dequeue ), 'HASH', 'enqueue dequeue complex'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue(3) ), 'abc', 'enqueue dequeue count'; } # enqueue dequeue_nb if ($^O ne 'MSWin32') { $chnl->enqueue('a string'); is $chnl->dequeue_nb, 'a string', 'enqueue dequeue_nb scalar'; $chnl->enqueue($sappho_text); is $chnl->dequeue_nb, $sappho_text, 'enqueue dequeue_nb utf8'; $chnl->enqueue($come_then_i_pray); is $chnl->dequeue_nb, $come_then_i_pray, 'enqueue dequeue_nb utf8_ja'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue_nb ), 'a', 'enqueue dequeue_nb item1'; is scalar( my $item2 = $chnl->dequeue_nb ), 'list', 'enqueue dequeue_nb item2'; is scalar( my $item3 = $chnl->dequeue_nb ), 'of', 'enqueue dequeue_nb item3'; is scalar( my $item4 = $chnl->dequeue_nb ), 'items', 'enqueue dequeue_nb item4'; $chnl->enqueue({ complex => 'structure' }); is ref( $chnl->dequeue_nb ), 'HASH', 'enqueue dequeue_nb complex'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue_nb(3) ), 'abc', 'enqueue dequeue_nb count'; } # end if ($^O ne 'MSWin32') { $chnl->enqueue("item $_") for 1 .. 2; $chnl->end; for my $method (qw/ send enqueue /) { local $SIG{__WARN__} = sub { is $_[0], "WARNING: ($method) called on a channel that has been 'end'ed\n", "channel ended, $method"; }; $chnl->$method("item"); } is $chnl->dequeue_nb, 'item 1', 'channel ended, dequeue_nb item 1'; is $chnl->dequeue_nb, 'item 2', 'channel ended, dequeue_nb item 2'; } done_testing; MCE-1.901/t/04_channel_mutexfast.t000644 000765 000024 00000006453 14204362655 017064 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { plan skip_all => "Not used on MSWin32" if ( $^O eq 'MSWin32' ); use_ok 'MCE::Channel'; use_ok 'MCE::Channel::MutexFast'; } my $chnl = MCE::Channel->new( impl => 'MutexFast' ); is $chnl->impl, 'MutexFast', 'implementation name'; # send recv { $chnl->send('a string'); is $chnl->recv, 'a string', 'send recv scalar'; $chnl->send(''); is $chnl->recv, '', 'send recv blank string'; $chnl->send(undef); is $chnl->recv, '', 'send recv undef stringified'; } # send recv_nb { $chnl->send('a string'); is $chnl->recv_nb, 'a string', 'send recv_nb scalar'; $chnl->send(''); is $chnl->recv_nb, '', 'send recv_nb blank string'; $chnl->send(undef); is $chnl->recv_nb, '', 'send recv_nb undef stringified'; } # send2 recv2 { $chnl->send2('a string'); is $chnl->recv2, 'a string', 'send2 recv2 scalar'; $chnl->send2(''); is $chnl->recv2, '', 'send2 recv2 blank string'; $chnl->send2(undef); is $chnl->recv2, '', 'send2 recv2 undef stringified'; } # send2 recv2_nb { $chnl->send2('a string'); is $chnl->recv2_nb, 'a string', 'send2 recv2_nb scalar'; $chnl->send2(''); is $chnl->recv2_nb, '', 'send2 recv2_nb blank string'; $chnl->send2(undef); is $chnl->recv2_nb, '', 'send2 recv2_nb undef stringified'; } # enqueue dequeue { $chnl->enqueue('a string'); is $chnl->dequeue, 'a string', 'enqueue dequeue scalar'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue ), 'a', 'enqueue dequeue item1'; is scalar( my $item2 = $chnl->dequeue ), 'list', 'enqueue dequeue item2'; is scalar( my $item3 = $chnl->dequeue ), 'of', 'enqueue dequeue item3'; is scalar( my $item4 = $chnl->dequeue ), 'items', 'enqueue dequeue item4'; $chnl->enqueue(''); is $chnl->dequeue, '', 'enqueue dequeue blank string'; $chnl->enqueue(undef); is $chnl->dequeue, '', 'enqueue dequeue undef stringified'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue(3) ), 'abc', 'enqueue dequeue count'; } # enqueue dequeue_nb { $chnl->enqueue('a string'); is $chnl->dequeue_nb, 'a string', 'enqueue dequeue_nb scalar'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue_nb ), 'a', 'enqueue dequeue_nb item1'; is scalar( my $item2 = $chnl->dequeue_nb ), 'list', 'enqueue dequeue_nb item2'; is scalar( my $item3 = $chnl->dequeue_nb ), 'of', 'enqueue dequeue_nb item3'; is scalar( my $item4 = $chnl->dequeue_nb ), 'items', 'enqueue dequeue_nb item4'; $chnl->enqueue(''); is $chnl->dequeue_nb, '', 'enqueue dequeue_nb blank string'; $chnl->enqueue(undef); is $chnl->dequeue_nb, '', 'enqueue dequeue_nb undef stringified'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue_nb(3) ), 'abc', 'enqueue dequeue_nb count'; } # end { $chnl->enqueue("item $_") for 1 .. 2; $chnl->end; for my $method (qw/ send enqueue /) { local $SIG{__WARN__} = sub { is $_[0], "WARNING: ($method) called on a channel that has been 'end'ed\n", "channel ended, $method"; }; $chnl->$method("item"); } is $chnl->dequeue_nb, 'item 1', 'channel ended, dequeue_nb item 1'; is $chnl->dequeue_nb, 'item 2', 'channel ended, dequeue_nb item 2'; } done_testing; MCE-1.901/t/05_mce_grep.t000644 000765 000024 00000001767 13671467746 015157 0ustar00mariostaff000000 000000 #!/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', 'check results for array' ); @a = mce_grep \&_task, [ 1..9 ]; is( join('', @a), '369', 'check results for array ref' ); @a = mce_grep_f \&_task, $in_file; is( join('', @a), '369', 'check results for path' ); @a = mce_grep_f \&_task, $fh_data; is( join('', @a), '369', 'check results for glob' ); @a = mce_grep_s \&_task, 1, 9; is( join('', @a), '369', '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.901/t/04_channel_threads_mp.t000644 000765 000024 00000012642 14435464172 017172 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use utf8; use open qw(:std :utf8); use Test::More; BEGIN { plan skip_all => "Not used on Cygwin" if ( $^O eq 'cygwin' ); if ( $] lt '5.010001' && $^O ne 'MSWin32' ) { plan skip_all => "old Perl and threads not supported on Unix platforms"; } eval 'use threads'; ## no critic plan skip_all => "threads not available" if $@; use_ok 'MCE::Channel'; use_ok 'MCE::Channel::Threads'; } ## https://sacred-texts.com/cla/usappho/sph02.htm (IV) my $sappho_text = "αῖψα δ᾽ ἐχίκοντο, σὺ δ᾽, ὦ μάσαιρα μειδιάσαισ᾽ ἀθάνατῳ προσώπῳ, ἤρἐ ὄττι δηὖτε πέπονθα κὤττι δἦγτε κάλημι."; my $translation = "Then, soon they arrived and thou, blessed goddess, With divine contenance smiling, didst ask me What new woe had befallen me now and why, Thus I had called the."; my $come_then_i_pray = "さあ、私は祈る" . "Ǣ"; my $chnl = MCE::Channel->new( impl => 'Threads', mp => 1 ); is $chnl->impl(), 'Threads', 'implementation name'; # send recv { $chnl->send('a string'); is $chnl->recv, 'a string', 'send recv scalar'; $chnl->send($sappho_text); is $chnl->recv, $sappho_text, 'send recv utf8'; $chnl->send($come_then_i_pray); is $chnl->recv, $come_then_i_pray, 'send recv utf8_ja'; $chnl->send(qw/ a list of arguments /); is scalar( my @args = $chnl->recv ), 4, 'send recv list'; $chnl->send({ complex => 'structure' }); is ref( $chnl->recv ), 'HASH', 'send recv complex'; } # send recv_nb if ($^O ne 'MSWin32') { $chnl->send('a string'); is $chnl->recv_nb, 'a string', 'send recv_nb scalar'; $chnl->send($sappho_text); is $chnl->recv_nb, $sappho_text, 'send recv_nb utf8'; $chnl->send($come_then_i_pray); is $chnl->recv_nb, $come_then_i_pray, 'send recv_nb utf8_ja'; $chnl->send(qw/ a list of arguments /); is scalar( my @args = $chnl->recv_nb ), 4, 'send recv_nb list'; $chnl->send({ complex => 'structure' }); is ref( $chnl->recv_nb ), 'HASH', 'send recv_nb complex'; } # send2 recv2 { $chnl->send2('a string'); is $chnl->recv2, 'a string', 'send2 recv2 scalar'; $chnl->send2($sappho_text); is $chnl->recv2, $sappho_text, 'send2 recv2 utf8'; $chnl->send2($come_then_i_pray); is $chnl->recv2, $come_then_i_pray, 'send2 recv2 utf8_ja'; $chnl->send2(qw/ a list of arguments /); is scalar( my @args = $chnl->recv2 ), 4, 'send2 recv2 list'; $chnl->send2({ complex => 'structure' }); is ref( $chnl->recv2 ), 'HASH', 'send2 recv2 complex'; } # send2 recv2_nb if ($^O ne 'MSWin32') { $chnl->send2('a string'); is $chnl->recv2_nb, 'a string', 'send2 recv2_nb scalar'; $chnl->send2($sappho_text); is $chnl->recv2_nb, $sappho_text, 'send2 recv2_nb utf8'; $chnl->send2($come_then_i_pray); is $chnl->recv2_nb, $come_then_i_pray, 'send2 recv2_nb utf8_ja'; $chnl->send2(qw/ a list of arguments /); is scalar( my @args = $chnl->recv2_nb ), 4, 'send2 recv2_nb list'; $chnl->send2({ complex => 'structure' }); is ref( $chnl->recv2_nb ), 'HASH', 'send2 recv2_nb complex'; } # enqueue dequeue { $chnl->enqueue('a string'); is $chnl->dequeue, 'a string', 'enqueue dequeue scalar'; $chnl->enqueue($sappho_text); is $chnl->dequeue, $sappho_text, 'enqueue dequeue utf8'; $chnl->enqueue($come_then_i_pray); is $chnl->dequeue, $come_then_i_pray, 'enqueue dequeue utf8_ja'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue ), 'a', 'enqueue dequeue item1'; is scalar( my $item2 = $chnl->dequeue ), 'list', 'enqueue dequeue item2'; is scalar( my $item3 = $chnl->dequeue ), 'of', 'enqueue dequeue item3'; is scalar( my $item4 = $chnl->dequeue ), 'items', 'enqueue dequeue item4'; $chnl->enqueue({ complex => 'structure' }); is ref( $chnl->dequeue ), 'HASH', 'enqueue dequeue complex'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue(3) ), 'abc', 'enqueue dequeue count'; } # enqueue dequeue_nb if ($^O ne 'MSWin32') { $chnl->enqueue('a string'); is $chnl->dequeue_nb, 'a string', 'enqueue dequeue_nb scalar'; $chnl->enqueue($sappho_text); is $chnl->dequeue_nb, $sappho_text, 'enqueue dequeue_nb utf8'; $chnl->enqueue($come_then_i_pray); is $chnl->dequeue_nb, $come_then_i_pray, 'enqueue dequeue_nb utf8_ja'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue_nb ), 'a', 'enqueue dequeue_nb item1'; is scalar( my $item2 = $chnl->dequeue_nb ), 'list', 'enqueue dequeue_nb item2'; is scalar( my $item3 = $chnl->dequeue_nb ), 'of', 'enqueue dequeue_nb item3'; is scalar( my $item4 = $chnl->dequeue_nb ), 'items', 'enqueue dequeue_nb item4'; $chnl->enqueue({ complex => 'structure' }); is ref( $chnl->dequeue_nb ), 'HASH', 'enqueue dequeue_nb complex'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue_nb(3) ), 'abc', 'enqueue dequeue_nb count'; } # end if ($^O ne 'MSWin32') { $chnl->enqueue("item $_") for 1 .. 2; $chnl->end; for my $method (qw/ send enqueue /) { local $SIG{__WARN__} = sub { is $_[0], "WARNING: ($method) called on a channel that has been 'end'ed\n", "channel ended, $method"; }; $chnl->$method("item"); } is $chnl->dequeue_nb, 'item 1', 'channel ended, dequeue_nb item 1'; is $chnl->dequeue_nb, 'item 2', 'channel ended, dequeue_nb item 2'; } done_testing; MCE-1.901/t/04_channel_threadsfast_mp.t000644 000765 000024 00000007157 14435464207 020054 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { plan skip_all => "Not used on Cygwin" if ( $^O eq 'cygwin' ); if ( $] lt '5.010001' && $^O ne 'MSWin32' ) { plan skip_all => "old Perl and threads not supported on Unix platforms"; } eval 'use threads'; ## no critic plan skip_all => "threads not available" if $@; use_ok 'MCE::Channel'; use_ok 'MCE::Channel::ThreadsFast'; } my $chnl = MCE::Channel->new( impl => 'ThreadsFast', mp => 1 ); is $chnl->impl(), 'ThreadsFast', 'implementation name'; # send recv { $chnl->send('a string'); is $chnl->recv, 'a string', 'send recv scalar'; $chnl->send(''); is $chnl->recv, '', 'send recv blank string'; $chnl->send(undef); is $chnl->recv, '', 'send recv undef stringified'; } # send recv_nb if ($^O ne 'MSWin32') { $chnl->send('a string'); is $chnl->recv_nb, 'a string', 'send recv_nb scalar'; $chnl->send(''); is $chnl->recv_nb, '', 'send recv_nb blank string'; $chnl->send(undef); is $chnl->recv_nb, '', 'send recv_nb undef stringified'; } # send2 recv2 { $chnl->send2('a string'); is $chnl->recv2, 'a string', 'send2 recv2 scalar'; $chnl->send2(''); is $chnl->recv2, '', 'send2 recv2 blank string'; $chnl->send2(undef); is $chnl->recv2, '', 'send2 recv2 undef stringified'; } # send2 recv2_nb if ($^O ne 'MSWin32') { $chnl->send2('a string'); is $chnl->recv2_nb, 'a string', 'send2 recv2_nb scalar'; $chnl->send2(''); is $chnl->recv2_nb, '', 'send2 recv2_nb blank string'; $chnl->send2(undef); is $chnl->recv2_nb, '', 'send2 recv2_nb undef stringified'; } # enqueue dequeue { $chnl->enqueue('a string'); is $chnl->dequeue, 'a string', 'enqueue dequeue scalar'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue ), 'a', 'enqueue dequeue item1'; is scalar( my $item2 = $chnl->dequeue ), 'list', 'enqueue dequeue item2'; is scalar( my $item3 = $chnl->dequeue ), 'of', 'enqueue dequeue item3'; is scalar( my $item4 = $chnl->dequeue ), 'items', 'enqueue dequeue item4'; $chnl->enqueue(''); is $chnl->dequeue, '', 'enqueue dequeue blank string'; $chnl->enqueue(undef); is $chnl->dequeue, '', 'enqueue dequeue undef stringified'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue(3) ), 'abc', 'enqueue dequeue count'; } # enqueue dequeue_nb if ($^O ne 'MSWin32') { $chnl->enqueue('a string'); is $chnl->dequeue_nb, 'a string', 'enqueue dequeue_nb scalar'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue_nb ), 'a', 'enqueue dequeue_nb item1'; is scalar( my $item2 = $chnl->dequeue_nb ), 'list', 'enqueue dequeue_nb item2'; is scalar( my $item3 = $chnl->dequeue_nb ), 'of', 'enqueue dequeue_nb item3'; is scalar( my $item4 = $chnl->dequeue_nb ), 'items', 'enqueue dequeue_nb item4'; $chnl->enqueue(''); is $chnl->dequeue_nb, '', 'enqueue dequeue_nb blank string'; $chnl->enqueue(undef); is $chnl->dequeue_nb, '', 'enqueue dequeue_nb undef stringified'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue_nb(3) ), 'abc', 'enqueue dequeue_nb count'; } # end if ($^O ne 'MSWin32') { $chnl->enqueue("item $_") for 1 .. 2; $chnl->end; for my $method (qw/ send enqueue /) { local $SIG{__WARN__} = sub { is $_[0], "WARNING: ($method) called on a channel that has been 'end'ed\n", "channel ended, $method"; }; $chnl->$method("item"); } is $chnl->dequeue_nb, 'item 1', 'channel ended, dequeue_nb item 1'; is $chnl->dequeue_nb, 'item 2', 'channel ended, dequeue_nb item 2'; } done_testing; MCE-1.901/t/06_nodata_flow.t000644 000765 000024 00000000521 13671470033 015636 0ustar00mariostaff000000 000000 #!/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.901/t/00_required_modules.t000644 000765 000024 00000000656 14437504116 016715 0ustar00mariostaff000000 000000 #!/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( sleep time )); } done_testing; MCE-1.901/t/01_load_signal_arg.t000644 000765 000024 00000002270 13006204541 016433 0ustar00mariostaff000000 000000 #!/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.901/t/01_load_signal_export.t000644 000765 000024 00000000374 13006204541 017206 0ustar00mariostaff000000 000000 #!/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.901/t/05_mce_child.t000644 000765 000024 00000005353 14355146054 015262 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use utf8; use open qw(:std :utf8); use Test::More; use Time::HiRes 'sleep'; BEGIN { use_ok 'MCE::Child'; use_ok 'MCE::Channel'; } { my ( $cnt, @list, %pids, %ret ); local $_; my $chnl = MCE::Channel->new( impl => 'MutexFast' ); my $come_then_i_pray = "さあ、私は祈る" . "Ǣ"; ok( 1, "spawning asynchronously" ); MCE::Child->create( sub { $chnl->recv; "$come_then_i_pray $_" } ) for 1..3; %pids = map { $_ => undef } MCE::Child->list_pids; is ( scalar( keys %pids ), 3, 'check for unique pids' ); @list = MCE::Child->list_running; is ( scalar @list, 3, 'check list_running' ); @list = MCE::Child->list_joinable; is ( scalar @list, 0, 'check list_joinable' ); @list = MCE::Child->list; is ( scalar @list, 3, 'check list' ); is ( MCE::Child->pending, 3, 'check pending' ); $cnt = 0; for ( @list ) { ++$cnt; is ( $_->is_running, 1, 'check is_running child'.$cnt ); is ( $_->is_joinable, '', 'check is_joinable child'.$cnt ); } $chnl->send('') for 1..3; $cnt = 0; for ( @list ) { ++$cnt; $ret{ $_->join } = 1; is ( $_->error, undef, 'check error child'.$cnt ); } is ( scalar keys %ret, 3, 'check for unique values' ); for ( sort keys %ret ) { my $id = chop; s/ $//; is ( $_, $come_then_i_pray, "check for utf8 string $id" ); }; } { my ( $cnt, @procs ); local $_; for ( 1..3 ) { push @procs, MCE::Child->create( sub { sleep 1 for 1..9; return 1 } ); } $procs[0]->exit(); $procs[1]->exit(); $procs[2]->kill('QUIT'); $cnt = 0; for ( @procs ) { ++$cnt; is ( $_->join, undef, 'check exit child'.$cnt ); } } { sub task { my ( $id ) = @_; return $id; } my $cnt_start = 0; my $cnt_finish = 0; MCE::Child->init( on_start => sub { my ( $pid, $id ) = @_; ++$cnt_start; }, on_finish => sub { my ( $pid, $exit, $id, $sig, $err, @ret ) = @_; ++$cnt_finish; } ); MCE::Child->create(\&task, 2); my $child = MCE::Child->wait_one(); my $err = $child->error || 'no error'; my $res = $child->result; my $pid = $child->pid; is ( $res, "2", 'check wait_one' ); my (@procs, @result); local $_; push @procs, MCE::Child->create(\&task, $_) for 1..3; MCE::Child->wait_all(); for my $child ( @procs ) { my $err = $child->error || 'no error'; my $res = $child->result; my $pid = $child->pid; push @result, $res; } is ( "@result", "1 2 3", 'check wait_all' ); is ( $cnt_start , 4, 'check on_start' ); is ( $cnt_finish, 4, 'check on_finish' ); } is ( MCE::Child->finish(), undef, 'check finish' ); done_testing; MCE-1.901/t/04_channel_threadsfast.t000644 000765 000024 00000007146 14435464200 017347 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { plan skip_all => "Not used on Cygwin" if ( $^O eq 'cygwin' ); if ( $] lt '5.010001' && $^O ne 'MSWin32' ) { plan skip_all => "old Perl and threads not supported on Unix platforms"; } eval 'use threads'; ## no critic plan skip_all => "threads not available" if $@; use_ok 'MCE::Channel'; use_ok 'MCE::Channel::ThreadsFast'; } my $chnl = MCE::Channel->new( impl => 'ThreadsFast' ); is $chnl->impl(), 'ThreadsFast', 'implementation name'; # send recv { $chnl->send('a string'); is $chnl->recv, 'a string', 'send recv scalar'; $chnl->send(''); is $chnl->recv, '', 'send recv blank string'; $chnl->send(undef); is $chnl->recv, '', 'send recv undef stringified'; } # send recv_nb if ($^O ne 'MSWin32') { $chnl->send('a string'); is $chnl->recv_nb, 'a string', 'send recv_nb scalar'; $chnl->send(''); is $chnl->recv_nb, '', 'send recv_nb blank string'; $chnl->send(undef); is $chnl->recv_nb, '', 'send recv_nb undef stringified'; } # send2 recv2 { $chnl->send2('a string'); is $chnl->recv2, 'a string', 'send2 recv2 scalar'; $chnl->send2(''); is $chnl->recv2, '', 'send2 recv2 blank string'; $chnl->send2(undef); is $chnl->recv2, '', 'send2 recv2 undef stringified'; } # send2 recv2_nb if ($^O ne 'MSWin32') { $chnl->send2('a string'); is $chnl->recv2_nb, 'a string', 'send2 recv2_nb scalar'; $chnl->send2(''); is $chnl->recv2_nb, '', 'send2 recv2_nb blank string'; $chnl->send2(undef); is $chnl->recv2_nb, '', 'send2 recv2_nb undef stringified'; } # enqueue dequeue { $chnl->enqueue('a string'); is $chnl->dequeue, 'a string', 'enqueue dequeue scalar'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue ), 'a', 'enqueue dequeue item1'; is scalar( my $item2 = $chnl->dequeue ), 'list', 'enqueue dequeue item2'; is scalar( my $item3 = $chnl->dequeue ), 'of', 'enqueue dequeue item3'; is scalar( my $item4 = $chnl->dequeue ), 'items', 'enqueue dequeue item4'; $chnl->enqueue(''); is $chnl->dequeue, '', 'enqueue dequeue blank string'; $chnl->enqueue(undef); is $chnl->dequeue, '', 'enqueue dequeue undef stringified'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue(3) ), 'abc', 'enqueue dequeue count'; } # enqueue dequeue_nb if ($^O ne 'MSWin32') { $chnl->enqueue('a string'); is $chnl->dequeue_nb, 'a string', 'enqueue dequeue_nb scalar'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue_nb ), 'a', 'enqueue dequeue_nb item1'; is scalar( my $item2 = $chnl->dequeue_nb ), 'list', 'enqueue dequeue_nb item2'; is scalar( my $item3 = $chnl->dequeue_nb ), 'of', 'enqueue dequeue_nb item3'; is scalar( my $item4 = $chnl->dequeue_nb ), 'items', 'enqueue dequeue_nb item4'; $chnl->enqueue(''); is $chnl->dequeue_nb, '', 'enqueue dequeue_nb blank string'; $chnl->enqueue(undef); is $chnl->dequeue_nb, '', 'enqueue dequeue_nb undef stringified'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue_nb(3) ), 'abc', 'enqueue dequeue_nb count'; } # end if ($^O ne 'MSWin32') { $chnl->enqueue("item $_") for 1 .. 2; $chnl->end; for my $method (qw/ send enqueue /) { local $SIG{__WARN__} = sub { is $_[0], "WARNING: ($method) called on a channel that has been 'end'ed\n", "channel ended, $method"; }; $chnl->$method("item"); } is $chnl->dequeue_nb, 'item 1', 'channel ended, dequeue_nb item 1'; is $chnl->dequeue_nb, 'item 2', 'channel ended, dequeue_nb item 2'; } done_testing; MCE-1.901/t/01_load_signal_tag.t000644 000765 000024 00000000353 13006204541 016435 0ustar00mariostaff000000 000000 #!/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.901/t/04_prio_que_worker.t000644 000765 000024 00000021430 14437536006 016561 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use utf8; use open qw(:std :utf8); use Test::More; BEGIN { use_ok 'MCE::Flow'; use_ok 'MCE::Queue'; } MCE::Flow->init( max_workers => 1 ); ############################################################################### ## MCE::Queue provides 2 operating modes (manager and worker). ## This will test (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; ## https://sacred-texts.com/cla/usappho/sph02.htm (VII) my $sappho_text = "ἔλθε μοι καὶ νῦν, χαλεπᾶν δὲ λῦσον ἐκ μερίμναν ὄσσα δέ μοι τέλεσσαι θῦμοσ ἰμμέρρει τέλεσον, σὐ δ᾽ αὔτα σύμμαχοσ ἔσσο." . "Ǣ"; my $translation = "Come then, I pray, grant me surcease from sorrow, Drive away care, I beseech thee, O goddess Fulfil for me what I yearn to accomplish, Be thou my ally."; 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_unicode_in { my ($description) = @_; is( join('', @{ $q->_get_aref(5) }), $sappho_text, $description ); } sub check_unicode_out { my ($description, $value) = @_; is( $value, $sappho_text, $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)); $q->clear; $q->enqueuep(5, $sappho_text); MCE->do('check_unicode_in', 'fifo, check unicode enqueuep'); MCE->do('check_unicode_out', 'fifo, check unicode dequeue', $q->dequeue); $q->insertp(5, 0, $sappho_text); MCE->do('check_unicode_out', 'fifo, check unicode peekp', $q->peekp(5, 0)); MCE->do('check_unicode_out', 'fifo, check unicode insertp', $q->dequeue_nb); $q->enqueuep(5, $sappho_text); MCE->do('check_unicode_out', 'fifo, check unicode dequeue_timed', $q->dequeue_timed); 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)); $q->clear; $q->enqueuep(5, $sappho_text); MCE->do('check_unicode_in', 'lifo, check unicode enqueuep'); MCE->do('check_unicode_out', 'lifo, check unicode dequeue', $q->dequeue); $q->insertp(5, 0, $sappho_text); MCE->do('check_unicode_out', 'lifo, check unicode peekp', $q->peekp(5, 0)); MCE->do('check_unicode_out', 'lifo, check unicode insertp', $q->dequeue_nb); $q->enqueuep(5, $sappho_text); MCE->do('check_unicode_out', 'lifo, check unicode dequeue_timed', $q->dequeue_timed); 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.901/t/04_channel_mutex_mp.t000644 000765 000024 00000012144 13671570362 016677 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use utf8; use open qw(:std :utf8); use Test::More; BEGIN { plan skip_all => "Not used on MSWin32" if ( $^O eq 'MSWin32' ); use_ok 'MCE::Channel'; use_ok 'MCE::Channel::Mutex'; } ## https://sacred-texts.com/cla/usappho/sph02.htm (I) my $sappho_text = "Ποικιλόθρον᾽ ὰθάνατ᾽ ᾽Αφροδιτα, παῖ Δίοσ, δολόπλοκε, λίσσομαί σε μή μ᾽ ἄσαισι μήτ᾽ ὀνίαισι δάμνα, πότνια, θῦμον."; my $translation = "Shimmering-throned immortal Aphrodite, Daughter of Zeus, Enchantress, I implore thee, Spare me, O queen, this agony and anguish, Crush not my spirit."; my $come_then_i_pray = "さあ、私は祈る" . "Ǣ"; my $chnl = MCE::Channel->new( impl => 'Mutex', mp => 1 ); is $chnl->impl, 'Mutex', 'implementation name'; # send recv { $chnl->send('a string'); is $chnl->recv, 'a string', 'send recv scalar'; $chnl->send($sappho_text); is $chnl->recv, $sappho_text, 'send recv utf8'; $chnl->send($come_then_i_pray); is $chnl->recv, $come_then_i_pray, 'send recv utf8_ja'; $chnl->send(qw/ a list of arguments /); is scalar( my @args = $chnl->recv ), 4, 'send recv list'; $chnl->send({ complex => 'structure' }); is ref( $chnl->recv ), 'HASH', 'send recv complex'; } # send recv_nb { $chnl->send('a string'); is $chnl->recv_nb, 'a string', 'send recv_nb scalar'; $chnl->send($sappho_text); is $chnl->recv_nb, $sappho_text, 'send recv_nb utf8'; $chnl->send($come_then_i_pray); is $chnl->recv_nb, $come_then_i_pray, 'send recv_nb utf8_ja'; $chnl->send(qw/ a list of arguments /); is scalar( my @args = $chnl->recv_nb ), 4, 'send recv_nb list'; $chnl->send({ complex => 'structure' }); is ref( $chnl->recv_nb ), 'HASH', 'send recv_nb complex'; } # send2 recv2 { $chnl->send2('a string'); is $chnl->recv2, 'a string', 'send2 recv2 scalar'; $chnl->send2($sappho_text); is $chnl->recv2, $sappho_text, 'send2 recv2 utf8'; $chnl->send2($come_then_i_pray); is $chnl->recv2, $come_then_i_pray, 'send2 recv2 utf8_ja'; $chnl->send2(qw/ a list of arguments /); is scalar( my @args = $chnl->recv2 ), 4, 'send2 recv2 list'; $chnl->send2({ complex => 'structure' }); is ref( $chnl->recv2 ), 'HASH', 'send2 recv2 complex'; } # send2 recv2_nb { $chnl->send2('a string'); is $chnl->recv2_nb, 'a string', 'send2 recv2_nb scalar'; $chnl->send2($sappho_text); is $chnl->recv2_nb, $sappho_text, 'send2 recv2_nb utf8'; $chnl->send2($come_then_i_pray); is $chnl->recv2_nb, $come_then_i_pray, 'send2 recv2_nb utf8_ja'; $chnl->send2(qw/ a list of arguments /); is scalar( my @args = $chnl->recv2_nb ), 4, 'send2 recv2_nb list'; $chnl->send2({ complex => 'structure' }); is ref( $chnl->recv2_nb ), 'HASH', 'send2 recv2_nb complex'; } # enqueue dequeue { $chnl->enqueue('a string'); is $chnl->dequeue, 'a string', 'enqueue dequeue scalar'; $chnl->enqueue($sappho_text); is $chnl->dequeue, $sappho_text, 'enqueue dequeue utf8'; $chnl->enqueue($come_then_i_pray); is $chnl->dequeue, $come_then_i_pray, 'enqueue dequeue utf8_ja'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue ), 'a', 'enqueue dequeue item1'; is scalar( my $item2 = $chnl->dequeue ), 'list', 'enqueue dequeue item2'; is scalar( my $item3 = $chnl->dequeue ), 'of', 'enqueue dequeue item3'; is scalar( my $item4 = $chnl->dequeue ), 'items', 'enqueue dequeue item4'; $chnl->enqueue({ complex => 'structure' }); is ref( $chnl->dequeue ), 'HASH', 'enqueue dequeue complex'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue(3) ), 'abc', 'enqueue dequeue count'; } # enqueue dequeue_nb { $chnl->enqueue('a string'); is $chnl->dequeue_nb, 'a string', 'enqueue dequeue_nb scalar'; $chnl->enqueue($sappho_text); is $chnl->dequeue_nb, $sappho_text, 'enqueue dequeue_nb utf8'; $chnl->enqueue($come_then_i_pray); is $chnl->dequeue_nb, $come_then_i_pray, 'enqueue dequeue_nb utf8_ja'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue_nb ), 'a', 'enqueue dequeue_nb item1'; is scalar( my $item2 = $chnl->dequeue_nb ), 'list', 'enqueue dequeue_nb item2'; is scalar( my $item3 = $chnl->dequeue_nb ), 'of', 'enqueue dequeue_nb item3'; is scalar( my $item4 = $chnl->dequeue_nb ), 'items', 'enqueue dequeue_nb item4'; $chnl->enqueue({ complex => 'structure' }); is ref( $chnl->dequeue_nb ), 'HASH', 'enqueue dequeue_nb complex'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue_nb(3) ), 'abc', 'enqueue dequeue_nb count'; } # end { $chnl->enqueue("item $_") for 1 .. 2; $chnl->end; for my $method (qw/ send enqueue /) { local $SIG{__WARN__} = sub { is $_[0], "WARNING: ($method) called on a channel that has been 'end'ed\n", "channel ended, $method"; }; $chnl->$method("item"); } is $chnl->dequeue_nb, 'item 1', 'channel ended, dequeue_nb item 1'; is $chnl->dequeue_nb, 'item 2', 'channel ended, dequeue_nb item 2'; } done_testing; MCE-1.901/t/04_channel_mutex.t000644 000765 000024 00000012131 13671570356 016202 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use utf8; use open qw(:std :utf8); use Test::More; BEGIN { plan skip_all => "Not used on MSWin32" if ( $^O eq 'MSWin32' ); use_ok 'MCE::Channel'; use_ok 'MCE::Channel::Mutex'; } ## https://sacred-texts.com/cla/usappho/sph02.htm (II) my $sappho_text = "ἀλλά τυίδ᾽ ἔλθ᾽, αἴποτα κἀτέρωτα τᾶσ ἔμασ αύδωσ αἴοισα πήλγι ἔκλυεσ πάτροσ δὲ δόμον λίποισα χρύσιον ἦλθεσ."; my $translation = "Whenever before thou has hearkened to me-- To my voice calling to thee in the distance, And heeding, thou hast come, leaving thy father's Golden dominions."; my $come_then_i_pray = "さあ、私は祈る" . "Ǣ"; my $chnl = MCE::Channel->new( impl => 'Mutex' ); is $chnl->impl, 'Mutex', 'implementation name'; # send recv { $chnl->send('a string'); is $chnl->recv, 'a string', 'send recv scalar'; $chnl->send($sappho_text); is $chnl->recv, $sappho_text, 'send recv utf8'; $chnl->send($come_then_i_pray); is $chnl->recv, $come_then_i_pray, 'send recv utf8_ja'; $chnl->send(qw/ a list of arguments /); is scalar( my @args = $chnl->recv ), 4, 'send recv list'; $chnl->send({ complex => 'structure' }); is ref( $chnl->recv ), 'HASH', 'send recv complex'; } # send recv_nb { $chnl->send('a string'); is $chnl->recv_nb, 'a string', 'send recv_nb scalar'; $chnl->send($sappho_text); is $chnl->recv_nb, $sappho_text, 'send recv_nb utf8'; $chnl->send($come_then_i_pray); is $chnl->recv_nb, $come_then_i_pray, 'send recv_nb utf8_ja'; $chnl->send(qw/ a list of arguments /); is scalar( my @args = $chnl->recv_nb ), 4, 'send recv_nb list'; $chnl->send({ complex => 'structure' }); is ref( $chnl->recv_nb ), 'HASH', 'send recv_nb complex'; } # send2 recv2 { $chnl->send2('a string'); is $chnl->recv2, 'a string', 'send2 recv2 scalar'; $chnl->send2($sappho_text); is $chnl->recv2, $sappho_text, 'send2 recv2 utf8'; $chnl->send2($come_then_i_pray); is $chnl->recv2, $come_then_i_pray, 'send2 recv2 utf8_ja'; $chnl->send2(qw/ a list of arguments /); is scalar( my @args = $chnl->recv2 ), 4, 'send2 recv2 list'; $chnl->send2({ complex => 'structure' }); is ref( $chnl->recv2 ), 'HASH', 'send2 recv2 complex'; } # send2 recv2_nb { $chnl->send2('a string'); is $chnl->recv2_nb, 'a string', 'send2 recv2_nb scalar'; $chnl->send2($sappho_text); is $chnl->recv2_nb, $sappho_text, 'send2 recv2_nb utf8'; $chnl->send2($come_then_i_pray); is $chnl->recv2_nb, $come_then_i_pray, 'send2 recv2_nb utf8_ja'; $chnl->send2(qw/ a list of arguments /); is scalar( my @args = $chnl->recv2_nb ), 4, 'send2 recv2_nb list'; $chnl->send2({ complex => 'structure' }); is ref( $chnl->recv2_nb ), 'HASH', 'send2 recv2_nb complex'; } # enqueue dequeue { $chnl->enqueue('a string'); is $chnl->dequeue, 'a string', 'enqueue dequeue scalar'; $chnl->enqueue($sappho_text); is $chnl->dequeue, $sappho_text, 'enqueue dequeue utf8'; $chnl->enqueue($come_then_i_pray); is $chnl->dequeue, $come_then_i_pray, 'enqueue dequeue utf8_ja'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue ), 'a', 'enqueue dequeue item1'; is scalar( my $item2 = $chnl->dequeue ), 'list', 'enqueue dequeue item2'; is scalar( my $item3 = $chnl->dequeue ), 'of', 'enqueue dequeue item3'; is scalar( my $item4 = $chnl->dequeue ), 'items', 'enqueue dequeue item4'; $chnl->enqueue({ complex => 'structure' }); is ref( $chnl->dequeue ), 'HASH', 'enqueue dequeue complex'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue(3) ), 'abc', 'enqueue dequeue count'; } # enqueue dequeue_nb { $chnl->enqueue('a string'); is $chnl->dequeue_nb, 'a string', 'enqueue dequeue_nb scalar'; $chnl->enqueue($sappho_text); is $chnl->dequeue_nb, $sappho_text, 'enqueue dequeue_nb utf8'; $chnl->enqueue($come_then_i_pray); is $chnl->dequeue_nb, $come_then_i_pray, 'enqueue dequeue_nb utf8_ja'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue_nb ), 'a', 'enqueue dequeue_nb item1'; is scalar( my $item2 = $chnl->dequeue_nb ), 'list', 'enqueue dequeue_nb item2'; is scalar( my $item3 = $chnl->dequeue_nb ), 'of', 'enqueue dequeue_nb item3'; is scalar( my $item4 = $chnl->dequeue_nb ), 'items', 'enqueue dequeue_nb item4'; $chnl->enqueue({ complex => 'structure' }); is ref( $chnl->dequeue_nb ), 'HASH', 'enqueue dequeue_nb complex'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue_nb(3) ), 'abc', 'enqueue dequeue_nb count'; } # end { $chnl->enqueue("item $_") for 1 .. 2; $chnl->end; for my $method (qw/ send enqueue /) { local $SIG{__WARN__} = sub { is $_[0], "WARNING: ($method) called on a channel that has been 'end'ed\n", "channel ended, $method"; }; $chnl->$method("item"); } is $chnl->dequeue_nb, 'item 1', 'channel ended, dequeue_nb item 1'; is $chnl->dequeue_nb, 'item 2', 'channel ended, dequeue_nb item 2'; } done_testing; MCE-1.901/t/01_mutex_channel2.t000644 000765 000024 00000000334 13462452461 016255 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More; use MCE::Mutex; { my $mutex = MCE::Mutex->new( impl => 'Channel2' ); is( $mutex->impl(), 'Channel2', 'implementation name 1' ); } done_testing; MCE-1.901/t/05_mce_child_max_workers.t000644 000765 000024 00000003627 14152242043 017673 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE::Child'; } { no warnings 'redefine'; sub MCE::Util::get_ncpu { return 16; } } { # When max_workers is specified... (default undef, unlimited) # Going higher than the HW ncpu limit is possible. Simply specify the # number of workers desired. The minimum number of workers is 1. MCE::Child->init(max_workers => 0); is(MCE::Child->max_workers(), 1, "check that max_workers=>0 is 1"); MCE::Child->max_workers(5); is(MCE::Child->max_workers(), 5, "check that max_workers=>5 is 5"); MCE::Child->max_workers(20); is(MCE::Child->max_workers(), 20, "check that max_workers=>20 is 20"); } { # 'auto' is the number of logical processors. MCE::Child->init(max_workers => 'auto'); is(MCE::Child->max_workers(), 16, "check that max_workers=>'auto' is 16 logical cores" ); } { # One may specify a percentage starting with MCE::Child 1.876. # The minimum number of workers is 1. MCE::Child->init(max_workers => '0%'); is(MCE::Child->max_workers(), 1, "check that max_workers=>'0%' is 1 on HW with 16 logical cores" ); MCE::Child->max_workers('1%'); is(MCE::Child->max_workers(), 1, "check that max_workers=>'1%' is 1 on HW with 16 logical cores" ); MCE::Child->max_workers('25%'); is(MCE::Child->max_workers(), 4, "check that max_workers=>'25%' is 4 on HW with 16 logical cores" ); MCE::Child->max_workers('37.5%'); is(MCE::Child->max_workers(), 6, "check that max_workers=>'37.5%' is 6 on HW with 16 logical cores" ); MCE::Child->max_workers('100%'); is(MCE::Child->max_workers(), 16, "check that max_workers=>'100%' is 16 on HW with 16 logical cores" ); MCE::Child->max_workers('200%'); is(MCE::Child->max_workers(), 32, "check that max_workers=>'200%' is 32 on HW with 16 logical cores" ); } done_testing; MCE-1.901/t/03_max_workers.t000644 000765 000024 00000010517 14152243737 015711 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE'; use_ok 'MCE::Flow'; } { no warnings 'redefine'; sub MCE::Util::get_ncpu { return 16; } } { # Going higher than the HW ncpu limit is possible. Simply specify the # number of workers desired. The minimum number of workers is 1. my $mce = MCE->new(max_workers => 0); is($mce->max_workers(), 1, "check that max_workers=>0 is 1"); $mce = MCE->new(max_workers => 5); is($mce->max_workers(), 5, "check that max_workers=>5 is 5"); $mce = MCE->new(max_workers => 20); is($mce->max_workers(), 20, "check that max_workers=>20 is 20"); } { # The limit for 'auto' is 8 including on HW with more than 8 logical cores. # The minimum number of workers is 1. my $mce = MCE->new(max_workers => 'auto'); is($mce->max_workers(), 8, "check that max_workers=>'auto' is 8 on HW with 16 logical cores" ); $mce = MCE->new(max_workers => 'auto-8'); is($mce->max_workers(), 1, "check that max_workers=>'auto-8' is 1 on HW with 16 logical cores" ); $mce = MCE->new(max_workers => 'auto-1'); is($mce->max_workers(), 7, "check that max_workers=>'auto-1' is 7 on HW with 16 logical cores" ); $mce = MCE->new(max_workers => 'auto+1'); is($mce->max_workers(), 9, "check that max_workers=>'auto+1' is 9 on HW with 16 logical cores" ); $mce = MCE->new(max_workers => 'auto/2'); is($mce->max_workers(), 4, "check that max_workers=>'auto/2' is 4 on HW with 16 logical cores" ); $mce = MCE->new(max_workers => 'auto*0'); is($mce->max_workers(), 1, "check that max_workers=>'auto*0' is 1 on HW with 16 logical cores" ); $mce = MCE->new(max_workers => 'auto*2'); is($mce->max_workers(), 16, "check that max_workers=>'auto*2' is 16 on HW with 16 logical cores" ); $mce = MCE->new(user_tasks => [ { max_workers => 1 }, { max_workers => 'auto/2' }, { max_workers => 'auto+2' }, ]); is($mce->{user_tasks}[0]{max_workers}, 1, "check that task 0 max_workers=>'1' is 1 on HW with 16 logical cores" ); is($mce->{user_tasks}[1]{max_workers}, 4, "check that task 1 max_workers=>'auto/2' is 4 on HW with 16 logical cores" ); is($mce->{user_tasks}[2]{max_workers}, 10, "check that task 2 max_workers=>'auto+2' is 10 on HW with 16 logical cores" ); } { # One may specify a percentage starting with MCE 1.875. # Thanks to kcott@PerlMonks (Ken) for the idea. # https://www.perlmonks.org/?node_id=11134439 # The min-max number of workers is 1 and MCE::Util::get_ncpu(). my $mce = MCE->new(max_workers => '0%'); is($mce->max_workers(), 1, "check that max_workers=>'0%' is 1 on HW with 16 logical cores" ); $mce = MCE->new(max_workers => '1%'); is($mce->max_workers(), 1, "check that max_workers=>'1%' is 1 on HW with 16 logical cores" ); $mce = MCE->new(max_workers => '25%'); is($mce->max_workers(), 4, "check that max_workers=>'25%' is 4 on HW with 16 logical cores" ); $mce = MCE->new(max_workers => '37.5%'); is($mce->max_workers(), 6, "check that max_workers=>'37.5%' is 6 on HW with 16 logical cores" ); $mce = MCE->new(max_workers => '100%'); is($mce->max_workers(), 16, "check that max_workers=>'100%' is 16 on HW with 16 logical cores" ); $mce = MCE->new(max_workers => '200%'); is($mce->max_workers(), 32, "check that max_workers=>'200%' is 32 on HW with 16 logical cores" ); $mce = MCE->new(user_tasks => [ { max_workers => 1 }, { max_workers => '25%' }, { max_workers => '50%' }, ]); is($mce->{user_tasks}[0]{max_workers}, 1, "check that task 0 max_workers=>'1' is 1 on HW with 16 logical cores" ); is($mce->{user_tasks}[1]{max_workers}, 4, "check that task 1 max_workers=>'25%' is 4 on HW with 16 logical cores" ); is($mce->{user_tasks}[2]{max_workers}, 8, "check that task 2 max_workers=>'50%' is 8 on HW with 16 logical cores" ); } { MCE::Flow::init(max_workers => [1, '25%']); my @res; mce_flow { gather => \@res }, sub { MCE->gather('a'.MCE->task_wid()); }, # 1 worker sub { MCE->gather('b'.MCE->task_wid()); }; # 4 workers @res = sort @res; is("@res", "a1 b1 b2 b3 b4", "check that MCE::Flow ran with 5 workers"); MCE::Flow->finish(); } done_testing; MCE-1.901/t/04_norm_que_worker.t000644 000765 000024 00000015373 14437535763 016605 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use utf8; use open qw(:std :utf8); use Test::More; BEGIN { use_ok 'MCE::Flow'; use_ok 'MCE::Queue'; } MCE::Flow->init( max_workers => 1 ); ############################################################################### ## MCE::Queue provides 2 operating modes (manager and worker). ## This will test (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; ## https://sacred-texts.com/cla/usappho/sph02.htm (VI) my $sappho_text = "καὶ γάρ αἰ φεύγει, ταχέωσ διώξει, αἰ δὲ δῶρα μὴ δέκετ ἀλλά δώσει, αἰ δὲ μὴ φίλει ταχέωσ φιλήσει, κωὐκ ἐθέλοισα." . "Ǣ"; my $translation = "For if now she flees, quickly she shall follow And if she spurns gifts, soon shall she offer them Yea, if she knows not love, soon shall she feel it Even reluctant."; 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_unicode_in { my ($description) = @_; is( join('', @{ $q->_get_aref() }), $sappho_text, $description ); } sub check_unicode_out { my ($description, $value) = @_; is( $value, $sappho_text, $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)); $q->clear; $q->enqueue($sappho_text); MCE->do('check_unicode_in', 'fifo, check unicode enqueue'); MCE->do('check_unicode_out', 'fifo, check unicode dequeue', $q->dequeue); $q->insert(0, $sappho_text); MCE->do('check_unicode_out', 'fifo, check unicode peek', $q->peek(0)); MCE->do('check_unicode_out', 'fifo, check unicode insert', $q->dequeue_nb); $q->enqueue($sappho_text); MCE->do('check_unicode_out', 'fifo, check unicode dequeue_timed', $q->dequeue_timed); 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)); $q->clear; $q->enqueue($sappho_text); MCE->do('check_unicode_in', 'lifo, check unicode enqueue'); MCE->do('check_unicode_out', 'lifo, check unicode dequeue', $q->dequeue); $q->insert(0, $sappho_text); MCE->do('check_unicode_out', 'lifo, check unicode peek', $q->peek(0)); MCE->do('check_unicode_out', 'lifo, check unicode insert', $q->dequeue_nb); $q->enqueue($sappho_text); MCE->do('check_unicode_out', 'lifo, check unicode dequeue_timed', $q->dequeue_timed); return; }; MCE::Flow->finish; done_testing; MCE-1.901/t/04_channel_simple.t000644 000765 000024 00000012224 14435464147 016333 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use utf8; use open qw(:std :utf8); use Test::More; BEGIN { use_ok 'MCE::Channel'; use_ok 'MCE::Channel::Simple'; } ## https://sacred-texts.com/cla/usappho/sph02.htm (III) my $sappho_text = "ἄρμ᾽ ὐποζεύξαια, κάλοι δέ σ᾽ ἆγον ὤκεεσ στροῦθοι περὶ γᾶσ μελαίνασ πύκνα δινεῦντεσ πτέῤ ἀπ᾽ ὠράνω αἴθεροσ διὰ μέσσω."; my $translation = "With chariot yoked to thy fleet-winged coursers, Fluttering swift pinions over earth's darkness, And bringing thee through the infinite, gliding Downwards from heaven."; my $come_then_i_pray = "さあ、私は祈る" . "Ǣ"; my $chnl = MCE::Channel->new( impl => 'Simple' ); is $chnl->impl(), 'Simple', 'implementation name'; # send recv { $chnl->send('a string'); is $chnl->recv, 'a string', 'send recv scalar'; $chnl->send($sappho_text); is $chnl->recv, $sappho_text, 'send recv utf8'; $chnl->send($come_then_i_pray); is $chnl->recv, $come_then_i_pray, 'send recv utf8_ja'; $chnl->send(qw/ a list of arguments /); is scalar( my @args = $chnl->recv ), 4, 'send recv list'; $chnl->send({ complex => 'structure' }); is ref( $chnl->recv ), 'HASH', 'send recv complex'; } # send recv_nb if ($^O ne 'MSWin32') { $chnl->send('a string'); is $chnl->recv_nb, 'a string', 'send recv_nb scalar'; $chnl->send($sappho_text); is $chnl->recv_nb, $sappho_text, 'send recv_nb utf8'; $chnl->send($come_then_i_pray); is $chnl->recv_nb, $come_then_i_pray, 'send recv_nb utf8_ja'; $chnl->send(qw/ a list of arguments /); is scalar( my @args = $chnl->recv_nb ), 4, 'send recv_nb list'; $chnl->send({ complex => 'structure' }); is ref( $chnl->recv_nb ), 'HASH', 'send recv_nb complex'; } # send2 recv2 { $chnl->send2('a string'); is $chnl->recv2, 'a string', 'send2 recv2 scalar'; $chnl->send2($sappho_text); is $chnl->recv2, $sappho_text, 'send2 recv2 utf8'; $chnl->send2($come_then_i_pray); is $chnl->recv2, $come_then_i_pray, 'send2 recv2 utf8_ja'; $chnl->send2(qw/ a list of arguments /); is scalar( my @args = $chnl->recv2 ), 4, 'send2 recv2 list'; $chnl->send2({ complex => 'structure' }); is ref( $chnl->recv2 ), 'HASH', 'send2 recv2 complex'; } # send2 recv2_nb if ($^O ne 'MSWin32') { $chnl->send2('a string'); is $chnl->recv2_nb, 'a string', 'send2 recv2_nb scalar'; $chnl->send2($sappho_text); is $chnl->recv2_nb, $sappho_text, 'send2 recv2_nb utf8'; $chnl->send2($come_then_i_pray); is $chnl->recv2_nb, $come_then_i_pray, 'send2 recv2_nb utf8_ja'; $chnl->send2(qw/ a list of arguments /); is scalar( my @args = $chnl->recv2_nb ), 4, 'send2 recv2_nb list'; $chnl->send2({ complex => 'structure' }); is ref( $chnl->recv2_nb ), 'HASH', 'send2 recv2_nb complex'; } # enqueue dequeue { $chnl->enqueue('a string'); is $chnl->dequeue, 'a string', 'enqueue dequeue scalar'; $chnl->enqueue($sappho_text); is $chnl->dequeue, $sappho_text, 'enqueue dequeue utf8'; $chnl->enqueue($come_then_i_pray); is $chnl->dequeue, $come_then_i_pray, 'enqueue dequeue utf8_ja'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue ), 'a', 'enqueue dequeue item1'; is scalar( my $item2 = $chnl->dequeue ), 'list', 'enqueue dequeue item2'; is scalar( my $item3 = $chnl->dequeue ), 'of', 'enqueue dequeue item3'; is scalar( my $item4 = $chnl->dequeue ), 'items', 'enqueue dequeue item4'; $chnl->enqueue({ complex => 'structure' }); is ref( $chnl->dequeue ), 'HASH', 'enqueue dequeue complex'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue(3) ), 'abc', 'enqueue dequeue count'; } # enqueue dequeue_nb if ($^O ne 'MSWin32') { $chnl->enqueue('a string'); is $chnl->dequeue_nb, 'a string', 'enqueue dequeue_nb scalar'; $chnl->enqueue($sappho_text); is $chnl->dequeue_nb, $sappho_text, 'enqueue dequeue_nb utf8'; $chnl->enqueue($come_then_i_pray); is $chnl->dequeue_nb, $come_then_i_pray, 'enqueue dequeue_nb utf8_ja'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue_nb ), 'a', 'enqueue dequeue_nb item1'; is scalar( my $item2 = $chnl->dequeue_nb ), 'list', 'enqueue dequeue_nb item2'; is scalar( my $item3 = $chnl->dequeue_nb ), 'of', 'enqueue dequeue_nb item3'; is scalar( my $item4 = $chnl->dequeue_nb ), 'items', 'enqueue dequeue_nb item4'; $chnl->enqueue({ complex => 'structure' }); is ref( $chnl->dequeue_nb ), 'HASH', 'enqueue dequeue_nb complex'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue_nb(3) ), 'abc', 'enqueue dequeue_nb count'; } # end if ($^O ne 'MSWin32') { $chnl->enqueue("item $_") for 1 .. 2; $chnl->end; for my $method (qw/ send enqueue /) { local $SIG{__WARN__} = sub { is $_[0], "WARNING: ($method) called on a channel that has been 'end'ed\n", "channel ended, $method"; }; $chnl->$method("item"); } is $chnl->dequeue_nb, 'item 1', 'channel ended, dequeue_nb item 1'; is $chnl->dequeue_nb, 'item 2', 'channel ended, dequeue_nb item 2'; } done_testing; MCE-1.901/t/04_norm_que_manager.t000644 000765 000024 00000012247 14437535744 016702 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use utf8; use open qw(:std :utf8); use Test::More; BEGIN { use_ok 'MCE::Queue'; } ############################################################################### ## MCE::Queue provides 2 operating modes (manager and worker). ## This will test (normal queue) by the 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::_mce_m_pending; ## *{ 'MCE::Queue::peek' } = \&MCE::Queue::_mce_m_peek; ## https://sacred-texts.com/cla/usappho/sph02.htm (VI) my $sappho_text = "καὶ γάρ αἰ φεύγει, ταχέωσ διώξει, αἰ δὲ δῶρα μὴ δέκετ ἀλλά δώσει, αἰ δὲ μὴ φίλει ταχέωσ φιλήσει, κωὐκ ἐθέλοισα." . "Ǣ"; my $translation = "For if now she flees, quickly she shall follow And if she spurns gifts, soon shall she offer them Yea, if she knows not love, soon shall she feel it Even reluctant."; 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' ); $q->clear; $q->enqueue($sappho_text); is( join('', @{ $q->_get_aref() }), $sappho_text, 'fifo, check unicode enqueue' ); is( $q->dequeue, $sappho_text, 'fifo, check unicode dequeue' ); $q->insert(0, $sappho_text); is( $q->peek(0), $sappho_text, 'fifo, check unicode peek' ); is( $q->dequeue_nb, $sappho_text, 'fifo, check unicode insert' ); $q->enqueue($sappho_text); is( $q->dequeue_timed, $sappho_text, 'fifo, check unicode dequeue_timed' ); ############################################################################### ## 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' ); $q->clear; $q->enqueue($sappho_text); is( join('', @{ $q->_get_aref() }), $sappho_text, 'lifo, check unicode enqueue' ); is( $q->dequeue, $sappho_text, 'lifo, check unicode dequeue' ); $q->insert(0, $sappho_text); is( $q->peek(0), $sappho_text, 'lifo, check unicode peek' ); is( $q->dequeue_nb, $sappho_text, 'lifo, check unicode insert' ); $q->enqueue($sappho_text); is( $q->dequeue_timed, $sappho_text, 'lifo, check unicode dequeue_timed' ); done_testing; MCE-1.901/t/01_load_mce.t000644 000765 000024 00000001641 13066665353 015114 0ustar00mariostaff000000 000000 #!/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::Signal'); use_ok('MCE'); use_ok('MCE::Util'); use_ok('MCE::Mutex'); use_ok('MCE::Mutex::Channel'); use_ok('MCE::Mutex::Flock'); use_ok('MCE::Core::Input::Generator'); use_ok('MCE::Core::Input::Handle'); use_ok('MCE::Core::Input::Iterator'); use_ok('MCE::Core::Input::Request'); use_ok('MCE::Core::Input::Sequence'); use_ok('MCE::Core::Manager'); use_ok('MCE::Core::Validation'); use_ok('MCE::Core::Worker'); use_ok('MCE::Candy'); use_ok('MCE::Queue'); use_ok('MCE::Relay'); use_ok('MCE::Subs'); use_ok('MCE::Flow'); use_ok('MCE::Grep'); use_ok('MCE::Loop'); use_ok('MCE::Map'); use_ok('MCE::Step'); use_ok('MCE::Stream'); } done_testing; MCE-1.901/t/03_user_args.t000644 000765 000024 00000003157 13671570351 015344 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use utf8; use open qw(:std :utf8); use Test::More; BEGIN { use_ok 'MCE::Flow'; } my $come_then_i_pray = "さあ、私は祈る"; MCE::Flow->init( max_workers => 1 ); sub check_hello { my ($arg1, $arg2, $arg3) = @_; is( $arg1, 'hello', 'check user_args (array ref), hello' ); is( $arg2, 'there', 'check user_args (array ref), there' ); is( $arg3, $come_then_i_pray, 'check user_args (array ref), utf8' ); return; } sub check_sunny { my ($arg1, $arg2, $arg3) = @_; is( $arg1, 'sunny', 'check user_args (array ref), sunny' ); is( $arg2, 'today', 'check user_args (array ref), today' ); is( $arg3, $come_then_i_pray, 'check user_args (array ref), utf8' ); return; } sub check_utf_8 { my ($text) = @_; is( $text, $come_then_i_pray, 'check user_args (scalar val), utf8' ); return; } ## Workers persist between runs when passed a reference to a subroutine. sub task { my $data = MCE->user_args; # array reference if (ref $data) { my ($arg1, $arg2, $arg3) = @{ $data }; if ($data->[0] eq 'hello') { MCE->do('check_hello', $arg1, $arg2, $arg3); } else { MCE->do('check_sunny', $arg1, $arg2, $arg3); } } # scalar value else { MCE->do('check_utf_8', $data); } return; } mce_flow { user_args => [ 'hello', 'there', $come_then_i_pray ] }, \&task; mce_flow { user_args => [ 'sunny', 'today', $come_then_i_pray ] }, \&task; mce_flow { user_args => $come_then_i_pray }, \&task; ## Shutdown workers. MCE::Flow->finish; done_testing; MCE-1.901/t/06_relay.t000644 000765 000024 00000006263 13671570430 014470 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use utf8; use open qw(:std :utf8); use Test::More; BEGIN { use_ok 'MCE::Flow'; } ############################################################################### ## Relay ARRAY ## input_data is not required to run mce_flow ## ## statement(s) between relay_recv and relay ## are processed serially and orderly { my @ret = mce_flow { max_workers => 2, init_relay => [ 1, 1 ], }, sub { my $ind = MCE->wid - 1; for my $i ( 1 .. 4 ) { my @data = MCE->relay_recv; MCE->gather( $data[ $ind ] ); MCE->relay( sub { $_->[ $ind ] += 1 } ); } }; MCE::Flow->finish; my @data = MCE->relay_final; is( join('', sort @ret), '11223344', 'check relayed data - array' ); is( join('', @data), '55', 'check final value - array' ); } ############################################################################### ## Relay HASH { my @ret = mce_flow { max_workers => 2, init_relay => { 1 => 1, 2 => 1 }, }, sub { my $key = MCE->wid; for my $i ( 1 .. 4 ) { my %data = MCE->relay_recv; MCE->gather( $data{ $key } ); MCE->relay( sub { $_->{ $key } += 1 } ); } }; MCE::Flow->finish; my %data = MCE->relay_final; is( join('', sort @ret), '11223344', 'check relayed data - hash' ); is( join('', values %data), '55', 'check final value - hash' ); } ############################################################################### ## Relay SCALAR { my @ret = mce_flow { max_workers => 2, init_relay => 1, }, sub { for my $i ( 1 .. 4 ) { my $n = MCE->relay_recv; MCE->gather( $n ); MCE->relay( sub { $_ += 1 } ); } }; MCE::Flow->finish; my $val = MCE->relay_final; is( join('', sort @ret), '12345678', 'check relayed data - scalar' ); is( $val, '9', 'check final value - scalar' ); } ############################################################################### ## Relay UTF-8. This also tests gathering UTF-8 strings. ## https://sacred-texts.com/cla/usappho/sph02.htm (VII) my $sappho_text = "ἔλθε μοι καὶ νῦν, χαλεπᾶν δὲ λῦσον\n". "ἐκ μερίμναν ὄσσα δέ μοι τέλεσσαι\n". "θῦμοσ ἰμμέρρει τέλεσον, σὐ δ᾽ αὔτα\n". "σύμμαχοσ ἔσσο.\n"; my $translation = "Come then, I pray, grant me surcease from sorrow,\n". "Drive away care, I beseech thee, O goddess\n". "Fulfil for me what I yearn to accomplish,\n". "Be thou my ally.\n"; { my @data = mce_flow { max_workers => 2, init_relay => $sappho_text, }, sub { MCE->relay( sub { $_ .= "ὲ"; MCE->gather( "ἔλθε μοι καὶ νῦν".MCE->wid ); }); }; MCE::Flow->finish; my $text = MCE->relay_final; is( $data[0], "ἔλθε μοι καὶ νῦν"."1" , 'check gathered data - worker 1' ); is( $data[1], "ἔλθε μοι καὶ νῦν"."2" , 'check gathered data - worker 2' ); is( $text , $sappho_text."ὲὲ" , 'check final value - utf8' ); } done_testing; MCE-1.901/t/04_channel_simplefast.t000644 000765 000024 00000006504 14435464161 017211 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE::Channel'; use_ok 'MCE::Channel::SimpleFast'; } my $chnl = MCE::Channel->new( impl => 'SimpleFast' ); is $chnl->impl(), 'SimpleFast', 'implementation name'; # send recv { $chnl->send('a string'); is $chnl->recv, 'a string', 'send recv scalar'; $chnl->send(''); is $chnl->recv, '', 'send recv blank string'; $chnl->send(undef); is $chnl->recv, '', 'send recv undef stringified'; } # send recv_nb if ($^O ne 'MSWin32') { $chnl->send('a string'); is $chnl->recv_nb, 'a string', 'send recv_nb scalar'; $chnl->send(''); is $chnl->recv_nb, '', 'send recv_nb blank string'; $chnl->send(undef); is $chnl->recv_nb, '', 'send recv_nb undef stringified'; } # send2 recv2 { $chnl->send2('a string'); is $chnl->recv2, 'a string', 'send2 recv2 scalar'; $chnl->send2(''); is $chnl->recv2, '', 'send2 recv2 blank string'; $chnl->send2(undef); is $chnl->recv2, '', 'send2 recv2 undef stringified'; } # send2 recv2_nb if ($^O ne 'MSWin32') { $chnl->send2('a string'); is $chnl->recv2_nb, 'a string', 'send2 recv2_nb scalar'; $chnl->send2(''); is $chnl->recv2_nb, '', 'send2 recv2_nb blank string'; $chnl->send2(undef); is $chnl->recv2_nb, '', 'send2 recv2_nb undef stringified'; } # enqueue dequeue { $chnl->enqueue('a string'); is $chnl->dequeue, 'a string', 'enqueue dequeue scalar'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue ), 'a', 'enqueue dequeue item1'; is scalar( my $item2 = $chnl->dequeue ), 'list', 'enqueue dequeue item2'; is scalar( my $item3 = $chnl->dequeue ), 'of', 'enqueue dequeue item3'; is scalar( my $item4 = $chnl->dequeue ), 'items', 'enqueue dequeue item4'; $chnl->enqueue(''); is $chnl->dequeue, '', 'enqueue dequeue blank string'; $chnl->enqueue(undef); is $chnl->dequeue, '', 'enqueue dequeue undef stringified'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue(3) ), 'abc', 'enqueue dequeue count'; } # enqueue dequeue_nb if ($^O ne 'MSWin32') { $chnl->enqueue('a string'); is $chnl->dequeue_nb, 'a string', 'enqueue dequeue_nb scalar'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue_nb ), 'a', 'enqueue dequeue_nb item1'; is scalar( my $item2 = $chnl->dequeue_nb ), 'list', 'enqueue dequeue_nb item2'; is scalar( my $item3 = $chnl->dequeue_nb ), 'of', 'enqueue dequeue_nb item3'; is scalar( my $item4 = $chnl->dequeue_nb ), 'items', 'enqueue dequeue_nb item4'; $chnl->enqueue(''); is $chnl->dequeue_nb, '', 'enqueue dequeue_nb blank string'; $chnl->enqueue(undef); is $chnl->dequeue_nb, '', 'enqueue dequeue_nb undef stringified'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue_nb(3) ), 'abc', 'enqueue dequeue_nb count'; } # end if ($^O ne 'MSWin32') { $chnl->enqueue("item $_") for 1 .. 2; $chnl->end; for my $method (qw/ send enqueue /) { local $SIG{__WARN__} = sub { is $_[0], "WARNING: ($method) called on a channel that has been 'end'ed\n", "channel ended, $method"; }; $chnl->$method("item"); } is $chnl->dequeue_nb, 'item 1', 'channel ended, dequeue_nb item 1'; is $chnl->dequeue_nb, 'item 2', 'channel ended, dequeue_nb item 2'; } done_testing; MCE-1.901/t/02_do_callback_result.t000644 000765 000024 00000004235 13671570344 017165 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use utf8; use open qw(:std :utf8); use Test::More; BEGIN { use_ok 'MCE'; } my $come_then_i_pray = "さあ、私は祈る"; 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 { return $come_then_i_pray; } sub callback7 { my ($h_ref) = @_; @rpl = (); foreach (sort keys %{ $h_ref }) { $rpl[$_ - 1] = $h_ref->{$_}; } return; } sub callback8 { my ($utf8) = @_; push @ans, $utf8; } $mce = MCE->new( max_workers => 1, user_func => sub { my @reply = MCE->do('callback4'); my %reply = MCE->do('callback5', \@reply); my $utf8 = MCE->do('callback6'); MCE->do('callback7', \%reply); MCE->do('callback8', $utf8); return; } ); $mce->run; is(pop(@ans), $come_then_i_pray, 'test4: check that utf8 is correct'); is(join('', sort @ans), '1234', 'test5: check that list is correct'); is(join('', sort @rpl), '2468', 'test6: check that hash is correct'); done_testing; MCE-1.901/t/03_chunk_size.t000644 000765 000024 00000001565 13006204541 015500 0ustar00mariostaff000000 000000 #!/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.901/t/04_channel_mutexfast_mp.t000644 000765 000024 00000006464 14204362662 017560 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { plan skip_all => "Not used on MSWin32" if ( $^O eq 'MSWin32' ); use_ok 'MCE::Channel'; use_ok 'MCE::Channel::MutexFast'; } my $chnl = MCE::Channel->new( impl => 'MutexFast', mp => 1 ); is $chnl->impl, 'MutexFast', 'implementation name'; # send recv { $chnl->send('a string'); is $chnl->recv, 'a string', 'send recv scalar'; $chnl->send(''); is $chnl->recv, '', 'send recv blank string'; $chnl->send(undef); is $chnl->recv, '', 'send recv undef stringified'; } # send recv_nb { $chnl->send('a string'); is $chnl->recv_nb, 'a string', 'send recv_nb scalar'; $chnl->send(''); is $chnl->recv_nb, '', 'send recv_nb blank string'; $chnl->send(undef); is $chnl->recv_nb, '', 'send recv_nb undef stringified'; } # send2 recv2 { $chnl->send2('a string'); is $chnl->recv2, 'a string', 'send2 recv2 scalar'; $chnl->send2(''); is $chnl->recv2, '', 'send2 recv2 blank string'; $chnl->send2(undef); is $chnl->recv2, '', 'send2 recv2 undef stringified'; } # send2 recv2_nb { $chnl->send2('a string'); is $chnl->recv2_nb, 'a string', 'send2 recv2_nb scalar'; $chnl->send2(''); is $chnl->recv2_nb, '', 'send2 recv2_nb blank string'; $chnl->send2(undef); is $chnl->recv2_nb, '', 'send2 recv2_nb undef stringified'; } # enqueue dequeue { $chnl->enqueue('a string'); is $chnl->dequeue, 'a string', 'enqueue dequeue scalar'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue ), 'a', 'enqueue dequeue item1'; is scalar( my $item2 = $chnl->dequeue ), 'list', 'enqueue dequeue item2'; is scalar( my $item3 = $chnl->dequeue ), 'of', 'enqueue dequeue item3'; is scalar( my $item4 = $chnl->dequeue ), 'items', 'enqueue dequeue item4'; $chnl->enqueue(''); is $chnl->dequeue, '', 'enqueue dequeue blank string'; $chnl->enqueue(undef); is $chnl->dequeue, '', 'enqueue dequeue undef stringified'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue(3) ), 'abc', 'enqueue dequeue count'; } # enqueue dequeue_nb { $chnl->enqueue('a string'); is $chnl->dequeue_nb, 'a string', 'enqueue dequeue_nb scalar'; $chnl->enqueue(qw/ a list of items /); is scalar( my $item1 = $chnl->dequeue_nb ), 'a', 'enqueue dequeue_nb item1'; is scalar( my $item2 = $chnl->dequeue_nb ), 'list', 'enqueue dequeue_nb item2'; is scalar( my $item3 = $chnl->dequeue_nb ), 'of', 'enqueue dequeue_nb item3'; is scalar( my $item4 = $chnl->dequeue_nb ), 'items', 'enqueue dequeue_nb item4'; $chnl->enqueue(''); is $chnl->dequeue_nb, '', 'enqueue dequeue_nb blank string'; $chnl->enqueue(undef); is $chnl->dequeue_nb, '', 'enqueue dequeue_nb undef stringified'; $chnl->enqueue(qw/ a b c /); is join( '', $chnl->dequeue_nb(3) ), 'abc', 'enqueue dequeue_nb count'; } # end { $chnl->enqueue("item $_") for 1 .. 2; $chnl->end; for my $method (qw/ send enqueue /) { local $SIG{__WARN__} = sub { is $_[0], "WARNING: ($method) called on a channel that has been 'end'ed\n", "channel ended, $method"; }; $chnl->$method("item"); } is $chnl->dequeue_nb, 'item 1', 'channel ended, dequeue_nb item 1'; is $chnl->dequeue_nb, 'item 2', 'channel ended, dequeue_nb item 2'; } done_testing; MCE-1.901/t/05_mce_stream.t000644 000765 000024 00000004620 13671470023 015462 0ustar00mariostaff000000 000000 #!/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, '@a = stream: check results for array' ); @a = mce_stream \&_task_b, \&_task_a, [ 1..9 ]; is( join(' ', @a), $answers, '@a = stream: check results for array ref' ); @a = mce_stream_f \&_task_b, \&_task_a, $in_file; is( join(' ', @a), $answers, '@a = stream: check results for path' ); @a = mce_stream_f \&_task_b, \&_task_a, $fh_data; is( join(' ', @a), $answers, '@a = stream: check results for glob' ); @a = mce_stream_s \&_task_b, \&_task_a, 1, 9; is( join(' ', @a), $answers, '@a = stream: 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, 'stream \@a: check results for array' ); mce_stream \@a, \&_task_b, \&_task_a, [ 1..9 ]; is( join(' ', @a), $answers, 'stream \@a: check results for array ref' ); mce_stream_f \@a, \&_task_b, \&_task_a, $in_file; is( join(' ', @a), $answers, 'stream \@a: check results for path' ); mce_stream_f \@a, \&_task_b, \&_task_a, $fh_data; is( join(' ', @a), $answers, 'stream \@a: check results for glob' ); mce_stream_s \@a, \&_task_b, \&_task_a, 1, 9; is( join(' ', @a), $answers, 'stream \@a: 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, '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.901/t/01_mutex_channel.t000644 000765 000024 00000000500 13066665657 016203 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More; use MCE::Mutex; { my $mutex = MCE::Mutex->new( impl => 'Channel' ); is( $mutex->impl(), 'Channel', 'implementation name 1' ); } { my $mutex = MCE::Mutex->new(); is( $mutex->impl(), 'Channel', 'implementation name 2' ); } done_testing; MCE-1.901/t/06_nodata_step.t000644 000765 000024 00000000521 13671470044 015644 0ustar00mariostaff000000 000000 #!/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.901/t/06_candy.t000644 000765 000024 00000001467 14634335162 014454 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { use_ok 'MCE'; use_ok 'MCE::Flow'; use_ok 'MCE::Candy'; } { my @data; MCE->new( max_workers => 4, input_data => [ 1 .. 4 ], gather => MCE::Candy::out_iter_array(\@data), user_func => sub { my ($mce, $chunk_ref, $chunk_id) = @_; MCE->gather( $chunk_id, $chunk_ref->[0] * 2 ); } )->run; is( join('', @data), '2468', 'check out_iter_array' ); } { my @data; sub append_data { push @data, $_[0]; } mce_flow { max_workers => 4, gather => MCE::Candy::out_iter_callback(\&append_data) }, sub { MCE->gather( MCE->wid, MCE->wid * 2 ); }; MCE::Flow->finish; is( join('', @data), '2468', 'check out_iter_callback' ); } done_testing; MCE-1.901/t/00_required_signals.t000644 000765 000024 00000001137 13006204541 016666 0ustar00mariostaff000000 000000 #!/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.901/t/05_mce_map.t000644 000765 000024 00000002053 13671467773 014764 0ustar00mariostaff000000 000000 #!/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, 'check results for array' ); @a = mce_map \&_task, [ 1..9 ]; is( join(' ', @a), $answers, 'check results for array ref' ); @a = mce_map_f \&_task, $in_file; is( join(' ', @a), $answers, 'check results for path' ); @a = mce_map_f \&_task, $fh_data; is( join(' ', @a), $answers, 'check results for glob' ); @a = mce_map_s \&_task, 1, 9; is( join(' ', @a), $answers, '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.901/t/01_mutex_flock.t000644 000765 000024 00000001630 13066666042 015663 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More; use MCE::Mutex; { my $mutex = MCE::Mutex->new( impl => 'Flock' ); is( $mutex->impl(), 'Flock', 'implementation name 1' ); } { my ($tmp_dir, $tmp_file); if ($ENV{TEMP} && -d $ENV{TEMP} && -w _) { $tmp_dir = $ENV{TEMP}; } elsif ($ENV{TMPDIR} && -d $ENV{TMPDIR} && -w _) { $tmp_dir = $ENV{TMPDIR}; } elsif (-d '/tmp' && -w _) { $tmp_dir = '/tmp'; } else { done_testing; exit; } $tmp_dir =~ s{/$}{}; # remove tainted'ness from $tmp_dir if ($^O eq 'MSWin32') { ($tmp_file) = "$tmp_dir\\lockfile.$$.lock" =~ /(.*)/; } else { ($tmp_file) = "$tmp_dir/lockfile.$$.lock" =~ /(.*)/; } my $mutex = MCE::Mutex->new( path => $tmp_file ); is( $mutex->impl(), 'Flock', 'implementation name 2' ); unlink $tmp_file; } done_testing; MCE-1.901/t/04_prio_que_manager.t000644 000765 000024 00000015602 14437535774 016701 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use utf8; use open qw(:std :utf8); use Test::More; BEGIN { use_ok 'MCE::Queue'; } ############################################################################### ## MCE::Queue provides 2 operating modes (manager and worker). ## This will test (priority queue) by the 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::_mce_m_pending; ## *{ 'MCE::Queue::peekp' } = \&MCE::Queue::_mce_m_peekp; ## *{ 'MCE::Queue::peekh' } = \&MCE::Queue::_mce_m_peekh; ## *{ 'MCE::Queue::heap' } = \&MCE::Queue::_mce_m_heap; ## https://sacred-texts.com/cla/usappho/sph02.htm (VII) my $sappho_text = "ἔλθε μοι καὶ νῦν, χαλεπᾶν δὲ λῦσον ἐκ μερίμναν ὄσσα δέ μοι τέλεσσαι θῦμοσ ἰμμέρρει τέλεσον, σὐ δ᾽ αὔτα σύμμαχοσ ἔσσο." . "Ǣ"; my $translation = "Come then, I pray, grant me surcease from sorrow, Drive away care, I beseech thee, O goddess Fulfil for me what I yearn to accomplish, Be thou my ally."; 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' ); $q->clear; $q->enqueuep(5, $sappho_text); is( join('', @{ $q->_get_aref(5) }), $sappho_text, 'fifo, check unicode enqueuep' ); is( $q->dequeue, $sappho_text, 'fifo, check unicode dequeue' ); $q->insertp(5, 0, $sappho_text); is( $q->peekp(5, 0), $sappho_text, 'fifo, check unicode peekp' ); is( $q->dequeue_nb, $sappho_text, 'fifo, check unicode insertp' ); $q->enqueuep(5, $sappho_text); is( $q->dequeue_timed, $sappho_text, 'fifo, check unicode dequeue_timed' ); ############################################################################### ## 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' ); $q->clear; $q->enqueuep(5, $sappho_text); is( join('', @{ $q->_get_aref(5) }), $sappho_text, 'lifo, check unicode enqueuep' ); is( $q->dequeue, $sappho_text, 'lifo, check unicode dequeue' ); $q->insertp(5, 0, $sappho_text); is( $q->peekp(5, 0), $sappho_text, 'lifo, check unicode peekp' ); is( $q->dequeue_nb, $sappho_text, 'lifo, check unicode insertp' ); $q->enqueuep(5, $sappho_text); is( $q->dequeue_timed, $sappho_text, 'lifo, check unicode dequeue_timed' ); ############################################################################### ## 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.901/t/02_do_callback_args.t000644 000765 000024 00000001735 13671570337 016607 0ustar00mariostaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use utf8; use open qw(:std :utf8); use Test::More; BEGIN { use_ok 'MCE'; } my $come_then_i_pray = "さあ、私は祈る"; 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; } sub callback3 { my ($text) = @_; is($text, $come_then_i_pray, 'check utf8 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()); $self->do('callback3', $come_then_i_pray); return; } ); $mce->run; done_testing; MCE-1.901/t/05_mce_flow.t000644 000765 000024 00000005705 13671467736 015164 0ustar00mariostaff000000 000000 #!/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') { # One might want to call $q->end(). Do not do that here. # This queue is used again, subsequently. $q->enqueue((undef) x 2); # 2 workers } } ); mce_flow { gather => output_iterator(\@a) }, \&task_a, \&task_b, ( 1..9 ); is( join(' ', @a), $answers, 'check results for array' ); mce_flow { gather => output_iterator(\@a) }, \&task_a, \&task_b, [ 1..9 ]; is( join(' ', @a), $answers, 'check results for array ref' ); 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; ## process hash, current API available since 1.828 MCE::Flow->init( max_workers => 1 ); my %hash = map { $_ => $_ } ( 1 .. 9 ); my %res = mce_flow sub { my ($mce, $chunk_ref, $chunk_id) = @_; my %ret; for my $key ( keys %{ $chunk_ref } ) { $ret{$key} = $chunk_ref->{$key} * 2; } MCE->gather(%ret); }, \%hash; @a = map { $res{$_} } ( 1 .. 9 ); is( join(' ', @a), "2 4 6 8 10 12 14 16 18", 'check results for hash ref' ); MCE::Flow->finish; ## cleanup unlink $in_file; done_testing; __DATA__ 1 2 3 4 5 6 7 8 9 MCE-1.901/t/05_mce_loop.t000644 000765 000024 00000004216 13671467764 015163 0ustar00mariostaff000000 000000 #!/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 \&_task, [ 1..9 ]; is( join(' ', @a), $answers, 'check results for array ref' ); 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; ## process hash, current API available since 1.828 MCE::Loop->init( max_workers => 1 ); my %hash = map { $_ => $_ } ( 1 .. 9 ); my %res = mce_loop { my ($mce, $chunk_ref, $chunk_id) = @_; my %ret; for my $key ( keys %{ $chunk_ref } ) { $ret{$key} = $chunk_ref->{$key} * 2; } MCE->gather(%ret); } \%hash; @a = map { $res{$_} } ( 1 .. 9 ); is( join(' ', @a), "2 4 6 8 10 12 14 16 18", 'check results for hash ref' ); MCE::Loop->finish; ## cleanup unlink $in_file; done_testing; __DATA__ 1 2 3 4 5 6 7 8 9 MCE-1.901/bin/mce_grep000755 000765 000024 00000070377 13671053031 014676 0ustar00mariostaff000000 000000 #!/usr/bin/env perl ############################################################################### ## ---------------------------------------------------------------------------- ## A MCE-driven 'wrapper' script for grep-like C binaries. ## ## Making a wrapper for other grep-like binaries is easy. Simply link this ## script or make a copy. 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 in your path. ## ## agrep.exe (z)grep.exe (z)egrep.exe (z)fgrep.exe tre-agrep.exe ## agrep (z)grep (z)egrep (z)fgrep tre-agrep ## ## ln mce_grep mce_egrep ; ln mce_grep mce_zegrep ; (or) ln -s ... ## ln mce_grep mce_fgrep ; ln mce_grep mce_zfgrep ; (or) cp ... ## ln mce_grep mce_zgrep ## ## ln mce_grep mce_tre-agrep # binary is named tre-agrep ## ln mce_grep mce_agrep # or agrep ## ## Caveat for (z)grep, (z)egrep, and (z)fgrep. When '--chunklevel=file' is ## specified or passing a single file, MCE workers read the file in smaller ## chunks. This is fine, typically. However, the following grep options may ## report inaccurately due to crossing boundaries in regards to chunks. ## To ensure accuracy, run with '--chunklevel=list'. ## ## -A NUM, --after-context=NUM ## -B NUM, --before-context=NUM ## -C NUM, --context=NUM ## ## ============================================================================ ## ---------------------------------------------------------------------------- ## 2014-01-21 v1.008 ## Initial release 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. ## ## 2017-02-25 v1.011 ## When -r is specified and zero paths are given, start recursively in the ## current directory. Set chunk-level accordingly to list mode. ## ## 2017-03-01 v1.012 ## Updated logic for determining chunk level mode. Ditto for chunk size. ## Fixed an issue for not seeing STDERR output with '--chunk-level=file'. ## Added support for zgrep, zegrep, and zfgrep. Thank you, Jeff Rouse. ## https://www.activestate.com/blog/2016/12/grep-losing-its-grip ## ## 2017-03-27 v1.013 ## Check for $!{'EINTR'} during syswrite. ## ############################################################################### ############################################################################### ## ---------------------------------------------------------------------------- ## Which to choose? bin/mce_grep or mce-examples/other/egrep.pl ## ## (A) This wrapper script is good for expensive pattern matching, especially ## with agrep and tre-agrep. It supports more options due to being passed ## to the binary. It supports two levels of chunking specified with the ## --chunk-level={auto|file|list} option. Choose file for large files. ## ## (B) The egrep.pl script is a pure-Perl implementation with fewer options. ## It's strengh is searching a single file and/or with many expressions. ## https://github.com/marioroy/mce-examples/blob/master/other/egrep.pl ## ############################################################################### 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 Fcntl qw( O_RDONLY ); use Scalar::Util qw( looks_like_number ); use Errno (); use MCE::Signal qw( -use_dev_shm ); use MCE 1.5; # or later release ############################################################################### ## ---------------------------------------------------------------------------- ## Usage and validation. ## ############################################################################### sub usage { print <<"::_USAGE_BLOCK_END_::"; Options for Script: --max-workers=NUM override max workers (default auto, 8 maximum) --maxworkers=NUM e.g. auto*2, 16 --chunk-level=LEVEL override chunk level (default auto) --chunklevel=LEVEL chunk at [file] or [list] level --chunk-size=NUM[KM] override chunk size (set at limit if under or over) --chunksize=NUM[KM] [file] default: 8M minimum: 200K maximum: 20M [list] default: 1 minimum: 1 maximum: 200 --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'} ) { $cmd_path = "$_\\$cmd_name", last if (-x "$_\\$cmd_name"); } } else { $cmd_name .= '.exe' if $^O eq 'cygwin'; for ( split ':', $ENV{'PATH'} ) { $cmd_path = "$_/$cmd_name", last if (-x "$_/$cmd_name"); } } unless (defined $cmd_path) { print {*STDERR} "$prog_name: $cmd_name: command not found\n"; exit 2; } { my %valid_names = map { $_ => 1 } qw( grep.exe egrep.exe fgrep.exe zgrep.exe zegrep.exe zfgrep.exe grep egrep fgrep zgrep zegrep zfgrep agrep.exe tre-agrep.exe agrep 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( 'maxworkers|max-workers|max_workers=s' => \$max_workers, 'chunklevel|chunk-level|chunk_level=s' => \$chunk_level, 'chunksize|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 ($r_flag && !@files) { push @files, '.'; } 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 { ## Borrowed bits from IPC::Run3 for STDOUT/ERR. However, I settled ## on passing STDIN via open, for lesser overhead, versus calling ## system from observations made 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; } ## Got "maximal count of pending signals (NUM) exceeded" message. ## Thus the reason for using syswrite versus print below. local $SIG{PIPE} = sub { }; open $cmd_fh, '|-', $cmd_path, @args; # Run external command my $wrote = 0; # Write to STDIN WRITE: { $wrote += ( syswrite ( $cmd_fh, $$chunk_ref, length($$chunk_ref) - $wrote, $wrote )) or do { unless ( defined $wrote ) { redo WRITE if ( $! == Errno::EINTR() ); } }; } 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 <= 1 || $files[0] eq '-') && !$r_flag && $cmd_name !~ /^z/i) { $chunk_level = 'file'; } else { $chunk_level = 'list'; } } if ($chunk_level eq 'list') { $chunk_size = 200 if (!defined $chunk_size && @files > 200); $chunk_size = 1 if (!defined $chunk_size); $chunk_size = 200 if ($chunk_size > 200); $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)); }