forks-0.34/0040755000076500000240000000000011405353607010527 5ustar gamesforks-0.34/CHANGELOG0100755000076500000240000010055011405344774011747 0ustar games0.34 June 14 2010 ***** Bug fixes ***** Fix compatibility with perl 5.11 and later. (RT#56263) (Possible bug in core each() iterator, when using blessed globrefs as hash keys?) Main thread will no longer be ABRT signalled (to exit) if it is already shutting down. Fix usleep behavior on platforms without nanosleep support. (RT#52782) Fix test skip counts in forks08.t. (RT#52781) ***** Threads API consistency changes ***** Bumped threads $VERSION to 1.77, threads::shared $VERSION to 1.33 to match version-supported features and behavior. ***** Miscellaneous changes ***** Runtime 'require threads::shared' now correctly loads forks::shared in an ithreads-enabled Perl, as long as 'forks' was loaded first. Can default to the previous behavior with a true-value environment variable, THREADS_NO_PRELOAD_SHARED. (RT#56139) Use SvGETMAGIC macro instead of mg_get. Add module dependency requirements test. Updated to ppport.h 3.19. 0.33 April 8 2009 ***** Bug fixes ***** exit() in child process after fork() in user code no longer causes process hang. Address issue with Devel::Symdump and internal typeglob reference changes in Perl 5.10. ***** Miscellaneous changes ***** Removed Devel::Required (used only for forks development) from Makefile.PL required modules. 0.32 March 18 2009 ***** Miscellaneous changes ***** Minor change to forks08.t nanosleep usage when not available, to avoid srror. Made time tolerances consistent throughout forks08.t. 0.31 March 14 2009 ***** Threads API consistency changes ***** Module CLONE and CLONE_SKIP functions now are passed package name as first argument. When CLONE_SKIP true in package, all objects in child threads are now cleared. This occurs after fork (unavoidable affect of system fork COW), which hopefully should be portable with all non-perl modules. Note that arrays and hashes will be emptied, but not converted to undef scalar ref; this differs from ithreads (where all become undef scalar ref). Patches are welcome. Bumped threads $VERSION to 1.72, threads::shared $VERSION to 1.28 to match version-supported features and behavior. ***** Bug fixes ***** Improve package detection for CLONE and CLONE_SKIP; now identifies all packages in symbol table, not just packages identified by %INC. This allows for support of multiple modules in a file/module that may have CLONE or CLONE_SKIP functions. Improved Time::HiRes::nanosleep support detection. Corrected possible race condition with $thr->get_stack_size(). Documented expected behavior. ***** Miscellaneous changes ***** Added preliminary Perl debugger support. Defaults to tying TTY only to main thread, unless breakpoints exist in user code. Add some time tolerance in forks08.t, to accomodate for busy systems or slow signal handling. New CPAN module requirements: Devel::Symdump and Acme::Damn. Updated to ppport.h 3.16. 0.30 February 16 2009 ***** Bug fixes ***** Don't overload/define Time::HiRes usleep or nanosleep unless they are supported on target platform. Check for "Invalid value for shared scalar" errors when storing values in shared scalars. Shared scalar values containing user tied objects will no longer be treated as threads::shared objects when checking for circular references. ***** Miscellaneous changes ***** Overloaded sleep total sleep time is more accurate in cases where it might be interrupted by child thread shutdown (CHLD) signals. 0.29 February 2 2009 ***** Bug fixes ***** Shared variables that reference shared variables now consistently report the same thread-local reference memory address. Code refs can now be used as hash keys. Fix spurious warnings regarding mismatched Time::HiRes prototypes. Explicit mg_get in is_shared() to insure tied scalar fetched before ref check. ***** Threads API consistency changes ***** Can now store CODE refs in shared variables if using Storable >= 2.05. Can now use CODE refs as shared variable keys (stringified values work as expected). Bumped threads::shared $VERSION to 1.27 to match version-supported features and behavior. ***** Miscellaneous changes ***** Add Makefile build option to upgrade Storable to support using CODE refs in shared variable keys, if using Storable 2.05 or later. Round test suite sleep time check sensitivity to eliminate false positives on some (hardware) platforms. Using more portable prototype definitions with some versions of Test::HiRes. Scalar::Util 1.11 or later now required. Sys::SigAction 0.11 or later now required, as this correctly handles the 'safe' sigaction attribute. Fix typo in croak error text in cond_timedwait. 0.28 December 30 2008 ***** Bug fixes ***** join() and detach() now correctly propagate and throw exceptions to threads, in such cases as joining or detaching an already joined or detached thread. Threads now supports circular self-referential shared variables (i.e. my $x:shared; $x = \$x;) and consistently returns the correct REF value; circular-referental sets of variables are also supported, if defined before sharing with shared_clone()). forks::shared function is_shared() now understands REF type input and circular referential shared variables. is_shared() should now return a consistent address in all threads and for all variable types; however, note since it refences memory in the shared process, do NOT use the return value to perform direct memory access (not that it was intended for this purpose, anyway). Using single-declaration form of 'use constant' for Perl 5.6.x compatibility. Explicitly registering 'threads' warnings pragma, for Perl 5.6.x compatibility. Added more XS prototype compatibility with 5.6.x, allowing second forms of cond_wait and cond_timedwait to be better supported. Added second forms of cond_wait and cond_timedwait to Perl < 5.8 source filters (eliminates segfaults). Identified and implemented additional internal state conditions when error 'Cannot detach a joined thread' should occur. threads->list(threads::all) no longer returns threads that already have a thread blocking to join them. Corrected a few uses of hash and array iterators that modify structure in loop (using each() for hashes, separate array copy). ***** Threads API consistency changes ***** forks::shared now implements standard threads::shared function shared_clone(). Scalars that have a value and are shared afterwards will retain the shared value when running in native threads emulation mode. Restartable system calls (platform-dependent) and sleep (including Time::HiRes sleep, usleep, and nanosleep) should no longer be interrupted by CHLD signal, unless CHLD signal handler is defined in user code. This should more accurately represent process behavior with slow system calls, as would be expected with native ithreads. Bumped threads $VERSION to 1.71 and threads::shared $VERSION to 1.26 to match version-supported features and behavior. forks::shared share() now correctly checks the function prototype when disabled (e.g. when forks::shared is loaded without or before forks). CLONE method/function is now supported in main:: package (was ignored). CLONE_SKIP method/function is now supported. Usage details at: http://perldoc.perl.org/perl593delta.html#'CLONE_SKIP()' threads->object(0) now returns undef (main thread is not considered an object). Support for 'array' context type (alias for already supported 'list' type) when creating a new thread. Thread attempting to join self (while non-detached) returns an error. Now correctly storing/returning stack size settings, although not internally used for anything useful at this time. Core function rand() is now reseeded in each new thread (via srand()). ***** Miscellaneous changes ***** Added THREADS_NATIVE_EMULATION environment variable to allow users to have forks behave more like native ithreads ("buggy" behaviors and all). Removed source filter requirement for Perl 5.9+. (Now using internal PL_sharehook instead of Attribute::Handlers whenver possible, including with Perl 5.8.x.) Removed use of AUTOLOAD in forks::shared; may see a minor shared variable access performance improvement. Added signal blocking when doing fork() system call, to insure most reliable thread startup behavior (i.e. custom CHLD signal handler won't create instability). Made minor changes to the test suite to improve descriptions and suppress a few unnecessary warnings. Added internal patching mechanism to allow Test::More to work with Perl 5.8.1 and older (primarily for test suite backward compatibility). Silenced spurious Test::More "WOAH! ..." warnings in test suite, regarding Test::More being unaware of global test counting when mixing forks and threads. Added extra parameter error checking to XS code. Modified internal data manipulation for broadcast() to protect against occasional memory corruption with Perl 5.6.x (delete() on array appeared to cause rare segfaults). Added 'if' CPAN module to package requirements, for Perl 5.6 support (test suite). Updated to ppport.h 3.14. 0.27 January 27 2008 ***** Bug fixes ***** forks::shared now supports perl 5.9.0 and later (with a source filter). The requirement for a source filter is hopefully just a temporary solution until Attribute::Handlers can access the 'shared' attribute again (which perl 5.9 and later currently prevent, perhaps because they consider it a reserved word). Corrected perl 5.6 support, regarding incompatible XS function Perl prototypes (broken since 0.16). All internal %INC manipulation is now done at compilation (require) time. This corrects cases where modules that 'use threads::shared' before forks::shared has been loaded actually load ithreads-native threads::shared. Corrected bug regarding handling forks-server operation deferred signals (which was preventing them from being executed when they should be executed). ***** Miscellaneous changes ***** Forks now uses Perl core module Attribute::Handlers for 'shared' variable attribute handling. This also insures compatibility with any other modules that may use Attribute::Handlers. Removed BUS, FPE, ILL, SEGV, and SYS from list of "forks-aware" signal handlers for better cross-platform portability. Added POD strongly encouraging use of forks and forks::shared as FIRST modules. Now tracking last known CORE::GLOBAL::exit at require time, and resetting at END. This should insure that cases where forks wasn't first module to be loaded allows for other modules to still use their own custom exit methods. Moved 5.6.x source filter from forks.pm to forks::shared.pm, where it belongs. Added appropriate disabled functions (without prototypes) for perl 5.6.x when forks::shared is disabled if was loaded without loading forks first). 0.26 September 30 2007 ***** Bug fixes ***** Eliminated some warnings on platforms that do not implement all signals forks can monitor. Added boolean hook $forks::DEFER_INIT_BEGIN_REQUIRE to allow external modules to override forks server functions if forks loaded in a BEGIN block. ***** Miscellaneous changes ***** Added some logic in CHLD reapers for better cross-platform stability. Updated to ppport.h 3.12. 0.25 August 12 2007 ***** Bug fixes ***** Updated internal PID tracking to U32 size for increased portability across different kernels and kernel configurations. This corrects irregular issues with locks on such systems. Rewrote signal handling engine to be more portable and stable. Changes eliminated behavior on BSD kernels that would cause processes to improperly exit with an ABRT-triggered core dump. ***** Miscellaneous changes ***** Added some protections in test suite for non-mixed fork/thread safe Test::More module. Added tests for new signal handling engine. 0.24 July 9 2007 ***** Threads API consistency changes ***** Changed $thr->wantarray return value to 0-length string (was string '0') to meet standard wantarray scalar context return value. Added support for exit() and threads->exit() methodology and behavior. Added support for $thr->error() feature. Added a warning (and disallowing thread detach) if attempting to detach a thread that another thread is currently waiting to join. ***** Internal behavior changes ***** Added ability to swap primary process (main<->shared) that is parent of all processes in threaded application (via $ENV{THREADS_DAEMON_MODEL}); should help support co-existance with some fork-aware modules, like POE. Rewrote signal handling methodology to resolve stability issues with inter-thread and external process signaling. Addressed the limit of 65535 shared variables: you may now create up to 2^31-1 (2+ billion) shared variables. Note: shared variables are currently not memory deallocated even if they go out of scope in all threads; thus, it's NOT recommended to create too many (1k+) unless you have a requirement to do so. Shared var mem deallocation (when no longer referenced by any thread) will be addressed in a future release. Improved behavior of signal() and scope-exit unlock ordinal to insure that all threads, no matter what type of waiting they were performing, have an equal chance to receive the signal or re-acquire the lock. The old behavior gave preference towards regular waiting events for signal, and timedwaiting events waiting to reacquire the lock for unlock ordinal. Deprecated and removed deadlock detection 'resolve_signal' feature (as this could not be supported in new forks.pm signal handling logic). ***** Bug fixes ***** Shared variable in push() on shared array now works. Eliminated slow memory leak when creating many joinable threads: the shared process now reclaims all shared memory allocated for joinable threads, as long as the application (periodically) joins then after they complete. Eliminated "Performing cleanup for dead thread 0" errors when compiling a script (i.e. perl -c script.pl). This fix also eliminates double "syntax OK" reports when compiling a script. Fixed a case where detach after thread had already completed could result in incorrect thread group exit state reporting. Corrected a bug regarding recursive variable unlocking (was deleting instead of decrementing lock count). Fixed a few issues in test scripts regarding mis-reported errors related to older threads.pm installs or non-threaded Perl targets. Forks now starts correctly if called with 'require' or if forks::import is skipped for any reason. Added additional check in server to shutdown if main thread dies in a hard way (no notification to server or thread group). Added some extra protection in thread signaling (to insure that process exists before signaling it). Added some protection in test suite for issues with race-conditions in Test::More. Fixed race condition in forks07.t that could cause test to report an error. Fixed race issue in forks04.t that could cause script to error out on Perl instances with old native threads.pm libraries or no threads.pm library. ***** Miscellaneous changes ***** Added additional thread environment protection regarding fork occuring outside forks.pm module. Also silenced a few warnings that might have occured in such cases. Silenced a few more unnecessary run-time warnings in specific exception and error cases. Rewrote END behavior for more stability and better cleanup during thread (process) group exit. Added internal hooks to allow external modules to override default forks.pm fork logic. This should allow more flexibility to integrate forks with application-scope modifying environments (i.e. mod_perl, POE, Coro, etc.). Removed dependency on Reaper module. Updated version requirement for Scalar::Util module. Upgraded to ppport.h 3.11. Fixed some XS portability issues with older versions of Perl (5.8.1 and older). 0.23 8 April 2007 ***** Test suite fixes ***** Corrected issue in forks04.t that would cause irrelevant but terminal compilation errors if real threads.pm (1.34 or later) weren't present. ***** Miscellaneous changes ***** Silenced a warning during external fork (non-thread) process exit. Added some internal hooks to allow add-on modules (e.g. forks::BerkeleyDB) the opportunity to clean up global thread resources during shutdown. 0.22 19 March 2007 ***** Internal behavior changes ***** Thread manager process now forcefully kills any still active threads when it exits. This is intended to best simulate standard thread.pm thread cleanup during process exit. ***** Bug fixes ***** Corrected bug in shared server shutdown preventing complete cleanup. Corrected some platform and perl build sensitivities in the test suite. ***** Miscellaneous changes ***** Added additional stability against fork() outside of forks.pm. Tweaked some warnings and disabled some debug logging. 0.21 17 March 2007 This revision includes *many* core changes and improvements, so be sure to perform full testing with existing forks-enabled applications before upgrading. All changes have been exposed to extensive regression testing, so you may expect all new features to be reasonably stable unless otherwise noted with a *WARNING* tag. ***** New features ***** Enabled complete thread context support. Be sure to specify the context, either implicit or directly. This also means you may not get what you expect if you return values in a context that doesn't match your spec. Add optional, automatic deadlock detection (warnings) in threads::shared. Also added is_deadlocked() method (manual deadlock detection) for threads. Added set_deadlock_option class method to forks::shared (threads::shared). Aware of thread params at thread creation, e.g. threads->new({}, sub {}); Added complete support for $thr->wantarray and thread->wantarray. Added complete support for thread state: is_running, is_joinable, is_detached(). Added additional support to threads->list(), with package variables: threads::all, threads::running, and threads::joinable. Added support for 'use forks qw(stringify)'where the TID is returned for a threads object in string context. Added detailed last known state of all threads on main thread exit (or server process unexpected exit), like: Perl exited with active threads: x running and unjoined y finished and unjoined z running and detached Added stubs for get_stack_size and set_stack_size, although they don't do anything (yet). Added support for threads->_handle and $thr->_handle, although it currently does not guarantee a reference to the same memory address each time (will be addressed in a later release). Added support for inter-thread signaling using $thr->kill('SIG...'). *WARNING* This feature is still highly experimental and has known issues when sending a signal to a process sending or receiving socket data pertaining to a threads operation. This will be addressed in a future release. Added question during build process to allow forks to override threads namespace if target Perl does not have native threading built in. Added POD describing this feature and behavior implications. ***** Bug fixes ***** Corrected bug in threads::shared::scalar that prevented tieing without a pre-existing scalar reference. Localizing $? in END block to insure that main thread exit code isn't accidentally overwritten during shutdown. Corrected several cases where internal auto-vivification was not intended, but might cause internal variable state issues. Corrected bug where fork() followed by ->isthread() in a child process while parent process (a thread) was already waiting on a separate thread could cause internal synchronization issues. Corrected bug in ->list where scalar context would return last object, not the number of waiting threads. Added additional protection in END block against external fork() occuring outside our knowledge causing synchronization havoc with the thread process group. Removed delete from %DETACHED on thread exit, as this property is used for internal thread type and state checking. Updated some error handling to suppress some undefined variable warnings. ***** Internal behavior improvements ***** Added silent overload of Config.pm 'useithreads' property to insure all modules and scripts see a true value when forks is loaded. Added explicit signal trapping of all untrapped normal and error signals for consistent and safe thread exit behavior. Added defensive error handling around non-blocking server sockets to protect against interruptions or busy resources during read or write. This should also make UNIX socket support more stable on certain target architectures. Added defensive logic to cleanup internal resources for threads that appear to have exited in an unsafe manner (and that may have left forks::shared resources in a unclean state) or were terminated with SIGKILL. Rewrote _length(), _send(), and _receive() internal functions to protect against signal interruptions, busy resources, socket disconnections, full socket buffers, and miscellaneous socket errors, including adding retry logic where appropriate. Updated _join() server function with much more intelligent logic regarding the state of a thread during the join process and a few more error cases that it needed to check for. threads->yield() now does a 1 ms sleep. ***** Threads API consistency changes ***** Can now signal unlocked variable using cond_signal and cond_broadcast. Note: Signaling locked returns 1; signaling unlocked returns undef. Modified lock, cond_signal, and cond_broadcast to return undef (instead of 1) to be consistent with threads.pm. Overloaded != for thread objects. A failed thread spawn (fork) now prints a warning and returns undef instead of dieing out. Detach twice on the same thread now throws an error. Improved format and content of internal warnings, and warnings now respect warnings state in caller for category 'threads'. Bumped threads $VERSION to 1.26, threads::shared to 1.04 to match version-supported features and behavior. *** Miscellaneous changes *** Implemented initial framework for better message handling. This should help reduce overall CPU usage, and hopefully improve performance, using custom filter definition for request and response messages that do not require Storable freeze/thaw. Requests that currently implement this are: _lock and _unlock. Responses that currently implement this are: any generic boolean response. Made Time::HiRes a prerequisite now. This means that fractional cond_timedwait is now supported by default. Optimized sigset masking: now only one set is created at compile time and reused during execution. Now safely runs in taint mode when any potentially tainted environment vars are defined. Suppressing unnecessary warnings in the case that 'test' does not exist in /bin or /usr/bin. Silenced thread socket errors during thread shutdown process, unless debugging is enabled. Added basic blocking join poll checks, to help prevent against forever blocking join() cases in abnormal thread death circumstances. Thread shutdown now expects a response (to insure synchronized shutdown agreement with server process). General improvements in thread shutdown stability (primarily server-side). 0.20 5 October 2006 Fixed rare thread start race condition where parent thread would block indefinitely if child thread were to spawn, complete, and exit before the parent could obtain the TID associated with the child thread. Corrected a few cases in server timedwait handling, cond_broadcast, and cond_signal where a lock could be prematurely transferred to another thread if the main thread (tid 0) were holding the lock at the time the event expired. Modified cond_timedwait to support fractional seconds (if Time::HiRes is loaded before forks). Minor changes to forks.xs for backwards compatibility with gcc 2.96. Minor cleanup in (forks.xs) bless reference handling. When using INET sockets, peer address is validated against the loopback address (IPv4 127.0.0.1) before accepting the connection; otherwise, socket is immediately closed and a warning is emitted. Added THREADS_IP_MASK env param to allow override of default IP mask filter. Misc cleanup of internal server environment variable handling. Moved some server code into separate subroutines. 0.19 21 May 2006 Implemented an exported bless() function allow transparent bless() across threads with forks::shared. Implemented exported is_shared function in forks::shared. Implemented custom CHLD signal handler to cleanup zombie process. This change was introduced to resolve an issue on some platforms where using $SIG{CHLD}='IGNORE' resulted in the perl core system() function returning -1 instead of the exit code of the system call. This signal handler is only used if the target system's system() call returns -1 on success when $SIG{CHLD}='IGNORE'. Added THREADS_SIGCHLD_IGNORE to allow users to force forks to use $SIG{CHLD}='IGNORE' on systems where a custom CHLD signal handler is automatically installed to support correct exit code of perl core system() function. Added THREADS_NICE env param to allow user to adjust forks.pm server process POSIX::nice value when running as root. If unset, no change is made to the server process priority. This differs from the historical behavior of forks.pm defaulting to nice -19 when run as root. Patched XS code to be ANSI C86 compliant (again). Code was unintentionally changed to require a minimum of ANSI C89 compliance since 0.17. This should allow all gcc 2.95.x and other C86-compliant compilers to once again build forks.pm. Fixed prototype mismatch warning when disabling cond_wait when forks is not used before forks::shared. Added patch to quietly ignore sharing an already shared variable. forks::shared used to bombs out in such cases (e.g. $a:shared; share($a);). Updated to ppport.h 3.06. Implemented separate package versions for forks and threads. threads package version will represent the most recent threads.pm release that this module is functionally compatible with. Disabled call to server process on shared variable DESTROY calls to decrease server communication load, as none of the affected TIE classes implement custom DESTROY methods. 0.18 7 December 2005 Introduction of UNIX socket support. Socket descriptors are written to /var/tmp and given rw access by all by default for best support on multi-user systems. Importing SOMAXCONN and using for socket server listener max socket connections (was hard coded at 10) for best (and system-level flexible) thread spawn stability under high load. 0.17 14 May 2005 (unreleased) Added method cond_timedwait and added second forms of cond_wait and cond_timedwait per the ithread specification (where signal var differs from lock var). All elements of perl ithread interface are now implemented, with respect to perl 5.8.7. Added eval wrapper around new thread code execution to trap die events; thus, join() is now more robust (fewer chances for runtime hangs on '$thread->join' due to premature child thread termination). Fixed bug in _islocked in case where if main thread tried to unlock an already unlocked variable, it would not correctly enter if case and return undef or croak() due to undef value in @LOCKED resolving to numeric 0. 0.16 8 April 2004 Changed semantics of debugging function: must now specify environment variable THREADS_DEBUG to be able to enable and disable debugging. If the environment variable does not exist at compile time, then all of the debugging code is optimised away. So performance in production environments should be better than before. 29 March 2004 Goto &sub considered evil with regards to performance and memory leaking. Therefore removed goto's where appropriate. 0.15 14 January 2004 Just got too much mail from people attempting to use forks.pm on Windows. Decided to add check for Win32 to Makefile.PL to have it die when attempting to run on Windows. Added documentation to explain this. 0.14 7 January 2004 Removed dependency on load.pm: it really doesn't make sense in a forked environment: I don't know what I was thinking in that respect. Added dependency on IO::Socket 1.18: we do need auto-flushing sockets (which seems to be pretty standard nowadays, but just to make sure). Fixed problem with large values / structures being passed with some help from Jan-Pieter Cornet at the Amsterdam PM Meeting. Spotted by Paul Golds. Added test for it. 0.13 4 January 2004 Looked at fixing the problem with signalling unlocked variables. Unfortunately, there does not seem to be a quick solution. Need to abandon this idea right now until I have more time. Updated documentation to let the world know there is an inconsistency. Documented the THREADS_DEBUG environment variable and made sure it is unset during testing. Updated ppport.h to 2.009. Didn't expect any problems with 5.8.1, but you never know. 0.12 2 January 2004 Fixed problem with signalling thread 0. Spotted by Stephen Adkins. 0.11 28 December 2003 Added automatic required modules update using Devel::Required. Added requirement for Devel::Required, so that optional modules are listed as required on the appropriate systems. 0.10 11 November 2003 Added check for processes dieing at the length check of a message. Not 100% sure whether this will be the best way to handle the main thread dieing, e.g. when it exits before all threads have been joined. 0.09 24 October 2003 Apparently, Test::Harness cannot handle testing "threaded" scripts using an unthreaded Perl. Added test for threadedness of the Perl being used: if so, skips testing Thread::Queue. Spotted by several CPAN testers. 0.08 24 October 2003 Shared entities that were also blessed as an object, were not correctly handled (ref() versus Scalar::Util::reftype() ). Spotted by Jack Steadman. Now fixed by using reftype() rather than ref(). Dependency on Scalar::Util added (not sure when that became core). Added tests to excercise Thread::Queue (if available). 10 October 2003 Changed async() to make it a little faster by removing an extra call from the stack. 0.07 27 September 2003 Added error detection in case lock or cond_xxx were called on unshared variables or cond_xxx were called on an unlocked variable. Added tests for it in the test-suite. Added dummy package declaration to forks::shared.pm for CPAN's sake. Cleaned up the attribute handler code in forks::shared.pm a bit. 0.06 27 September 2003 Finally grokked the documentation about attributes. This allowed me to finally write the handler for the ":shared" attribute. Which in the end turned out to be surprisingly simple. Adapted the test-suite to test usage of the ":shared" attribute as opposed to sharing variables with the "share" subroutine. 0.05 26 September 2003 Increased dependency on load.pm to 0.11: versions of load.pm before that had issues with running under taint. Debug statements can now be activated by setting the environment variable THREADS_DEBUG to true. As this is still experimental, this feature is only described in the CHANGELOG for now. Fixed several issues when running under taint. Test-suite now runs in tainted mode just to be on the safe side. Removed some debug statements from the test-suite. 0.04 10 August 2003 Implemented .xs file munging and source-filter to be able to truly support forks.pm under Perl 5.6.x. Thanks to Juerd Waalboer for the idea of the source filter. It is now confirmed that forks.pm won't work under 5.005, so the minimum version of Perl is now set to 5.6.0 in the Makefile.PL. 7 August 2003 Tested under 5.8.1-RC4. The WHOA! messags seem to have disappeared but instead a warning has appeared that cannot be suppressed. This was caused by my attempt to activate the :shared attribute. Since that doesn't work anyway, I removed the offending code and the warning went away. Fixed some warnings in the test-suite. Fixed another warning in forks.pm. Reported by Bradley W. Langhorst. 0.03 2 April 2003 Fixed a warning in forks.pm. Reported by Bradley W. Langhorst. 0.02 17 January 2003 Added dummy -package forks- to forks.pm to fool CPAN into thinking it really is the forks.pm module, when in fact it is of course threads.pm. Fixed some warnings in t/forks01.t. 28 October 2002 Made sure length packing uses Network order. 0.01 27 October 2002 First public version of forks.pm. Thanks to Lars Fenneberg for all the help so far. forks-0.34/CREDITS0100644000076500000240000000331511405337772011553 0ustar gamesAll the people reporting problems and fixes. More specifically in alphabetical order: Alban Crequy For discovering that expected Perl exit code could be unintentionally overridden in forks END block and providing a patch suggestion. Elizabeth Mattijsen For providing me (Eric Rybski) the opportunity to maintain and improve this great module. Erwan Velu For finding that system() might not return correct exit value on certain target platforms. Nilson Santos Figueiredo Junior For helping identify a problem with locks and large PIDs, and for helping test and refine general BSD kernel compatibility. Richard Faasen For discovering that some XS code was incompatible with older gcc versions. threads::shared For some of the XS code used for forks::shared exported bless function, and for some code used for exported shared_clone function. ORIGINAL AUTHOR CREDITS Stephen Adkins For finding that a child thread could not wake the very first parent thread with cond_signal, and providing a patch to fix it. Arthur Bergman For implementing the first working version of Perl threads support and providing us with an API to build on. For Hook::Scope (from which I swiped the code to have locked variables automatically unlock upon leaving the scope they were locked in) and threads::shared (from which I swiped the code to create references from the parameter list passed to a subroutine). Lars Fenneberg For helping me through the initial birthing pains. Paul Golds For spotting a problem with very large shared scalar values. Bradley W. Langhorst For making sure everything runs with warnings enabled. Juerd Waalboer For pointing me to the source filter solution for Perl 5.6.x. forks-0.34/forks.xs0100444000076500000240000002426211405351361012223 0ustar games#include "EXTERN.h" #include "perl.h" #include "XSUB.h" #define NEED_PL_signals #include "ppport.h" #define MY_CXT_KEY "threads::shared::_guts" XS_VERSION typedef struct { int dummy; /* you can access this elsewhere as MY_CXT.dummy */ } my_cxt_t; START_MY_CXT /* Scope hook to determine when a locked variable should be unlocked */ void exec_leave(pTHX_ SV *both) { U32 process; U32 ordinal; AV *av_ord_lock; dSP; ENTER; SAVETMPS; av_ord_lock = (AV*)SvRV(both); process = (U32)SvUV((SV*)*av_fetch(av_ord_lock, 1, 0)); ordinal = (U32)SvUV((SV*)*av_fetch(av_ord_lock, 2, 0)); /* printf ("unlock: ordinal = %d, process = %d\n",ordinal,process); */ SvREFCNT_dec(av_ord_lock); SvREFCNT_dec(both); PUSHMARK(SP); XPUSHs(sv_2mortal(newSVuv(ordinal))); PUTBACK; if (process == getpid()) { call_pv( "threads::shared::_unlock",G_DISCARD ); } SPAGAIN; PUTBACK; FREETMPS; LEAVE; } /* Implements Perl-level share() and :shared */ void Perl_sharedsv_share(pTHX_ SV *sv) { dSP; switch(SvTYPE(sv)) { /* case SVt_PVGV: Perl_croak(aTHX_ "Cannot share globs yet"); break; */ case SVt_PVCV: Perl_croak(aTHX_ "Cannot share subs yet"); break; default: ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(sv_2mortal(newRV_inc(sv))); PUTBACK; call_pv( "threads::shared::_share",G_DISCARD ); SPAGAIN; PUTBACK; FREETMPS; LEAVE; break; } } /* Inititalize core Perl hooks */ void Perl_sharedsv_init(pTHX) { /* PL_lockhook = &Perl_sharedsv_locksv; */ #ifdef PL_sharehook PL_sharehook = &Perl_sharedsv_share; #endif #ifdef PL_destroyhook /* PL_destroyhook = &Perl_shared_object_destroy; */ #endif } MODULE = forks PACKAGE = threads::shared #---------------------------------------------------------------------- # OUT: 1 boolean value indicating whether core hook PL_sharehook exists bool __DEF_PL_sharehook() CODE: #ifdef PL_sharehook RETVAL = 1; #else RETVAL = 0; #endif OUTPUT: RETVAL #---------------------------------------------------------------------- # OUT: 1 boolean value indicating whether unsafe signals are in use bool _check_pl_signal_unsafe_flag() PREINIT: U32 flags; CODE: flags = PL_signals & PERL_SIGNALS_UNSAFE_FLAG; if (flags == 0) { RETVAL = 0; } else { RETVAL = 1; } OUTPUT: RETVAL #---------------------------------------------------------------------- # IN: 1 any variable (scalar,array,hash,glob) # OUT: 1 reference to that variable SV* share(SV *myref) PROTOTYPE: \[$@%] CODE: if (!SvROK(myref)) Perl_croak(aTHX_ "Argument to share needs to be passed as ref"); myref = SvRV(myref); if(SvROK(myref)) myref = SvRV(myref); Perl_sharedsv_share(aTHX_ myref); RETVAL = newRV_inc(myref); OUTPUT: RETVAL #---------------------------------------------------------------------- # IN: 1 any variable (scalar,array,hash,glob) void lock(SV *myref) PROTOTYPE: \[$@%] PPCODE: int count; U32 process; U32 ordinal; AV *av_ord_lock; LEAVE; if (!SvROK(myref)) Perl_croak(aTHX_ "Argument to lock needs to be passed as ref"); myref = SvRV(myref); if(SvROK(myref)) myref = SvRV(myref); ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv("_lock",0))); XPUSHs(sv_2mortal(newRV_inc(myref))); PUTBACK; process = getpid(); count = call_pv( "threads::shared::_remote",G_SCALAR ); SPAGAIN; ordinal = POPl; /* printf ("lock: ordinal = %d, process = %d\n",ordinal,process); */ PUTBACK; FREETMPS; LEAVE; av_ord_lock = newAV(); av_store(av_ord_lock, 1, newSVuv(process)); av_store(av_ord_lock, 2, newSVuv(ordinal)); SAVEDESTRUCTOR_X(exec_leave,newRV((SV*)av_ord_lock)); ENTER; #---------------------------------------------------------------------- # IN: 1 any variable (scalar,array,hash,glob) -- signal variable # 2 any variable (scalar,array,hash,glob) -- lock variable void cond_wait(SV *myref, SV *myref2 = 0) PROTOTYPE: \[$@%];\[$@%] CODE: if (!SvROK(myref)) Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref"); myref = SvRV(myref); if(SvROK(myref)) myref = SvRV(myref); ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv("_wait",0))); XPUSHs(sv_2mortal(newRV_inc(myref))); if (myref2 && myref != myref2) { if (!SvROK(myref2)) Perl_croak(aTHX_ "cond_wait lock needs to be passed as ref"); myref2 = SvRV(myref2); if(SvROK(myref2)) myref2 = SvRV(myref2); XPUSHs(sv_2mortal(newRV_inc(myref2))); } PUTBACK; call_pv( "threads::shared::_remote",G_DISCARD ); FREETMPS; LEAVE; #---------------------------------------------------------------------- # IN: 1 any variable (scalar,array,hash,glob) -- signal variable # 2 epoch time of event expiration # 3 any variable (scalar,array,hash,glob) -- lock variable int cond_timedwait(SV *myref, double epochts, SV *myref2 = 0) PROTOTYPE: \[$@%]$;\[$@%] PREINIT: int count; bool retval; U32 ordinal; CODE: if (!SvROK(myref)) Perl_croak(aTHX_ "Argument to cond_timedwait needs to be passed as ref"); myref = SvRV(myref); if(SvROK(myref)) myref = SvRV(myref); ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv("_timedwait",0))); XPUSHs(sv_2mortal(newRV_inc(myref))); XPUSHs(sv_2mortal(newSVnv(epochts))); if (myref2 && myref != myref2) { if (!SvROK(myref2)) Perl_croak(aTHX_ "cond_timedwait lock needs to be passed as ref"); myref2 = SvRV(myref2); if(SvROK(myref2)) myref2 = SvRV(myref2); XPUSHs(sv_2mortal(newRV_inc(myref2))); } PUTBACK; count = call_pv( "threads::shared::_remote",G_ARRAY ); SPAGAIN; if (count != 2) croak ("Error receiving response value from _remote\n"); retval = POPi; ordinal = POPi; PUTBACK; FREETMPS; LEAVE; RETVAL = retval; if (RETVAL == 0) XSRETURN_UNDEF; OUTPUT: RETVAL #---------------------------------------------------------------------- # IN: 1 any variable (scalar,array,hash,glob) void cond_signal(SV *myref) PROTOTYPE: \[$@%] CODE: if (!SvROK(myref)) Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref"); myref = SvRV(myref); if(SvROK(myref)) myref = SvRV(myref); ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv("_signal",0))); XPUSHs(sv_2mortal(newRV_inc(myref))); PUTBACK; call_pv( "threads::shared::_remote",G_DISCARD ); FREETMPS; LEAVE; #---------------------------------------------------------------------- # IN: 1 any variable (scalar,array,hash,glob) void cond_broadcast(SV *myref) PROTOTYPE: \[$@%] CODE: if (!SvROK(myref)) Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref"); myref = SvRV(myref); if(SvROK(myref)) myref = SvRV(myref); ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv("_broadcast",0))); XPUSHs(sv_2mortal(newRV_inc(myref))); PUTBACK; call_pv( "threads::shared::_remote",G_DISCARD ); FREETMPS; LEAVE; #---------------------------------------------------------------------- # IN: 1 scalar # IN: 1 optional scalar void bless(SV *myref, ...) PROTOTYPE: $;$ PREINIT: HV* stash; SV* classname; STRLEN len; char *ptr; SV* myref2; CODE: if (items == 1) { stash = CopSTASH(PL_curcop); } else { classname = ST(1); if (classname && ! SvGMAGICAL(classname) && ! SvAMAGIC(classname) && SvROK(classname)) { Perl_croak(aTHX_ "Attempt to bless into a reference"); } ptr = SvPV(classname, len); if (ckWARN(WARN_MISC) && len == 0) { Perl_warner(aTHX_ packWARN(WARN_MISC), "Explicit blessing to '' (assuming package main)"); } stash = gv_stashpvn(ptr, len, TRUE); } SvREFCNT_inc(myref); (void)sv_bless(myref, stash); ST(0) = sv_2mortal(myref); myref2 = SvRV(myref); if(SvROK(myref2)) { myref2 = SvRV(myref2); } ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv_2mortal(newRV(myref2))); XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0))); PUTBACK; call_pv( "threads::shared::_bless",G_DISCARD ); FREETMPS; LEAVE; #---------------------------------------------------------------------- # IN: 1 any variable (scalar,array,hash,glob) UV _id(SV *myref) PROTOTYPE: \[$@%] PREINIT: UV retval; CODE: if (!SvROK(myref)) Perl_croak(aTHX_ "Argument to _id needs to be passed as ref"); myref = SvRV(myref); SvGETMAGIC(myref); if(SvROK(myref)) myref = SvRV(myref); ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv_2mortal(newRV_inc(myref))); PUTBACK; call_pv( "threads::shared::__id",G_SCALAR ); SPAGAIN; retval = POPi; PUTBACK; FREETMPS; LEAVE; RETVAL = retval; OUTPUT: RETVAL #---------------------------------------------------------------------- BOOT: { MY_CXT_INIT; Perl_sharedsv_init(aTHX); } forks-0.34/lib/0040755000076500000240000000000011405351363011272 5ustar gamesforks-0.34/lib/forks/0040755000076500000240000000000011405351363012416 5ustar gamesforks-0.34/lib/forks/Devel/0040755000076500000240000000000011405353607013460 5ustar gamesforks-0.34/lib/forks/Devel/Symdump.pm0100644000076500000240000003041411166621530015450 0ustar gamespackage forks::Devel::Symdump; # hide from PAUSE use 5.003; use Carp (); use strict; use vars qw($Defaults $VERSION *ENTRY $MAX_RECURSION); $VERSION = '2.08001'; $MAX_RECURSION = 97; $Defaults = { 'RECURS' => 0, 'AUTOLOAD' => { 'packages' => 1, 'scalars' => 1, 'arrays' => 1, 'hashes' => 1, 'functions' => 1, 'ios' => 1, 'unknowns' => 1, }, 'SEEN' => {}, }; sub rnew { my($class,@packages) = @_; no strict "refs"; my $self = bless {%${"$class\::Defaults"}}, $class; $self->{RECURS}++; $self->_doit(@packages); } sub new { my($class,@packages) = @_; no strict "refs"; my $self = bless {%${"$class\::Defaults"}}, $class; $self->_doit(@packages); } sub _doit { my($self,@packages) = @_; @packages = ("main") unless @packages; $self->{RESULT} = $self->_symdump(@packages); return $self; } sub _symdump { my($self,@packages) = @_ ; my($key,$val,$num,$pack,@todo,$tmp); my $result = {}; foreach $pack (@packages){ no strict; while (($key,$val) = each(%{*{"$pack\::"}})) { my $gotone = 0; #### perl 5.10.x special case: SCALAR? #### if ($] >= 5.010 && defined $val) { if (ref($val) eq 'GLOB') { $result->{$pack}{SCALARS}{$key}++; $gotone++; next; } } local(*ENTRY) = $val; #### SCALAR #### if (defined $val && defined *ENTRY{SCALAR}) { $result->{$pack}{SCALARS}{$key}++; $gotone++; } #### ARRAY #### if (defined $val && defined *ENTRY{ARRAY}) { $result->{$pack}{ARRAYS}{$key}++; $gotone++; } #### HASH #### if (defined $val && defined *ENTRY{HASH} && $key !~ /::/) { $result->{$pack}{HASHES}{$key}++; $gotone++; } #### PACKAGE #### if (defined $val && defined *ENTRY{HASH} && $key =~ /::$/ && $key ne "main::" && $key ne "::") { my($p) = $pack ne "main" ? "$pack\::" : ""; ($p .= $key) =~ s/::$//; $result->{$pack}{PACKAGES}{$p}++; $gotone++; if (++$self->{SEEN}{*$val} > $forks::Devel::Symdump::MAX_RECURSION){ next; } push @todo, $p; } #### FUNCTION #### if (defined $val && defined *ENTRY{CODE}) { $result->{$pack}{FUNCTIONS}{$key}++; $gotone++; } #### IO #### had to change after 5.003_10 if ($] > 5.003_10){ if (defined $val && defined *ENTRY{IO}){ # fileno and telldir... $result->{$pack}{IOS}{$key}++; $gotone++; } } else { #### FILEHANDLE #### if (defined fileno(ENTRY)){ $result->{$pack}{IOS}{$key}++; $gotone++; } elsif (defined telldir(ENTRY)){ #### DIRHANDLE #### $result->{$pack}{IOS}{$key}++; $gotone++; } } #### SOMETHING ELSE #### unless ($gotone) { $result->{$pack}{UNKNOWNS}{$key}++; } } } return (@todo && $self->{RECURS}) ? { %$result, %{$self->_symdump(@todo)} } : $result; } sub _partdump { my($self,$part)=@_; my ($pack, @result); my $prepend = ""; foreach $pack (keys %{$self->{RESULT}}){ $prepend = "$pack\::" unless $part eq 'PACKAGES'; push @result, map {"$prepend$_"} keys %{$self->{RESULT}{$pack}{$part} || {}}; } return @result; } # this is needed so we don't try to AUTOLOAD the DESTROY method sub DESTROY {} sub as_string { my $self = shift; my($type,@m); for $type (sort keys %{$self->{'AUTOLOAD'}}) { push @m, $type; push @m, "\t" . join "\n\t", map { s/([\000-\037\177])/ '^' . pack('c', ord($1) ^ 64) /eg; $_; } sort $self->_partdump(uc $type); } return join "\n", @m; } sub as_HTML { my $self = shift; my($type,@m); push @m, ""; for $type (sort keys %{$self->{'AUTOLOAD'}}) { push @m, ""; push @m, ""; } push @m, "
$type" . join ", ", map { s/([\000-\037\177])/ '^' . pack('c', ord($1) ^ 64) /eg; $_; } sort $self->_partdump(uc $type); push @m, "
"; return join "\n", @m; } sub diff { my($self,$second) = @_; my($type,@m); for $type (sort keys %{$self->{'AUTOLOAD'}}) { my(%first,%second,%all,$symbol); foreach $symbol ($self->_partdump(uc $type)){ $first{$symbol}++; $all{$symbol}++; } foreach $symbol ($second->_partdump(uc $type)){ $second{$symbol}++; $all{$symbol}++; } my(@typediff); foreach $symbol (sort keys %all){ next if $first{$symbol} && $second{$symbol}; push @typediff, "- $symbol" unless $second{$symbol}; push @typediff, "+ $symbol" unless $first{$symbol}; } foreach (@typediff) { s/([\000-\037\177])/ '^' . pack('c', ord($1) ^ 64) /eg; } push @m, $type, @typediff if @typediff; } return join "\n", @m; } sub inh_tree { my($self) = @_; return $self->{INHTREE} if ref $self && defined $self->{INHTREE}; my($inherited_by) = {}; my($m)=""; my(@isa) = grep /\bISA$/, forks::Devel::Symdump->rnew->arrays; my $isa; foreach $isa (sort @isa) { $isa =~ s/::ISA$//; my($isaisa); no strict 'refs'; foreach $isaisa (@{"$isa\::ISA"}){ $inherited_by->{$isaisa}{$isa}++; } } my $item; foreach $item (sort keys %$inherited_by) { $m .= "$item\n"; $m .= _inh_tree($item,$inherited_by); } $self->{INHTREE} = $m if ref $self; $m; } sub _inh_tree { my($package,$href,$depth) = @_; return unless defined $href; $depth ||= 0; $depth++; if ($depth > 100){ warn "Deep recursion in ISA\n"; return; } my($m) = ""; # print "DEBUG: package[$package]depth[$depth]\n"; my $i; foreach $i (sort keys %{$href->{$package}}) { $m .= qq{\t} x $depth; $m .= qq{$i\n}; $m .= _inh_tree($i,$href,$depth); } $m; } sub isa_tree{ my($self) = @_; return $self->{ISATREE} if ref $self && defined $self->{ISATREE}; my(@isa) = grep /\bISA$/, forks::Devel::Symdump->rnew->arrays; my($m) = ""; my($isa); foreach $isa (sort @isa) { $isa =~ s/::ISA$//; $m .= qq{$isa\n}; $m .= _isa_tree($isa) } $self->{ISATREE} = $m if ref $self; $m; } sub _isa_tree{ my($package,$depth) = @_; $depth ||= 0; $depth++; if ($depth > 100){ warn "Deep recursion in ISA\n"; return; } my($m) = ""; # print "DEBUG: package[$package]depth[$depth]\n"; my $isaisa; no strict 'refs'; foreach $isaisa (@{"$package\::ISA"}) { $m .= qq{\t} x $depth; $m .= qq{$isaisa\n}; $m .= _isa_tree($isaisa,$depth); } $m; } AUTOLOAD { my($self,@packages) = @_; unless (ref $self) { $self = $self->new(@packages); } no strict "vars"; (my $auto = $AUTOLOAD) =~ s/.*:://; $auto =~ s/(file|dir)handles/ios/; my $compat = $1; unless ($self->{'AUTOLOAD'}{$auto}) { Carp::croak("invalid forks::Devel::Symdump method: $auto()"); } my @syms = $self->_partdump(uc $auto); if (defined $compat) { no strict 'refs'; local $^W; # bleadperl@26631 introduced an io warning here if ($compat eq "file") { @syms = grep { defined(fileno($_)) } @syms; } else { @syms = grep { defined(telldir($_)) } @syms; } } return @syms; # make sure now it gets context right } 1; __END__ =head1 NAME forks::Devel::Symdump - dump symbol names or the symbol table =head1 SYNOPSIS # Constructor require forks::Devel::Symdump; @packs = qw(some_package another_package); $obj = forks::Devel::Symdump->new(@packs); # no recursion $obj = forks::Devel::Symdump->rnew(@packs); # with recursion # Methods @array = $obj->packages; @array = $obj->scalars; @array = $obj->arrays; @array = $obj->hashes; @array = $obj->functions; @array = $obj->filehandles; # deprecated, use ios instead @array = $obj->dirhandles; # deprecated, use ios instead @array = $obj->ios; @array = $obj->unknowns; # only perl version < 5.003 had some $string = $obj->as_string; $string = $obj->as_HTML; $string = $obj1->diff($obj2); $string = forks::Devel::Symdump->isa_tree; # or $obj->isa_tree $string = forks::Devel::Symdump->inh_tree; # or $obj->inh_tree # Methods with autogenerated objects # all of those call new(@packs) internally @array = forks::Devel::Symdump->packages(@packs); @array = forks::Devel::Symdump->scalars(@packs); @array = forks::Devel::Symdump->arrays(@packs); @array = forks::Devel::Symdump->hashes(@packs); @array = forks::Devel::Symdump->functions(@packs); @array = forks::Devel::Symdump->ios(@packs); @array = forks::Devel::Symdump->unknowns(@packs); =head1 DESCRIPTION This little package serves to access the symbol table of perl. =over 4 =item Crnew(@packages)> returns a symbol table object for all subtrees below @packages. Nested Modules are analyzed recursively. If no package is given as argument, it defaults to C
. That means to get the whole symbol table, just do a C without arguments. The global variable $forks::Devel::Symdump::MAX_RECURSION limits the recursion to prevent contention. The default value is set to 97, just low enough to survive the test suite without a warning about deep recursion. =item Cnew(@packages)> does not go into recursion and only analyzes the packages that are given as arguments. =item packages, scalars, arrays, hashes, functions, ios The methods packages(), scalars(), arrays(), hashes(), functions(), ios(), and (for older perls) unknowns() each return an array of fully qualified symbols of the specified type in all packages that are held within a forks::Devel::Symdump object, but without the leading C<$>, C<@> or C<%>. In a scalar context, they will return the number of such symbols. Unknown symbols are usually either formats or variables that haven't yet got a defined value. =item as_string =item as_HTML As_string() and as_HTML() return a simple string/HTML representations of the object. =item diff Diff() prints the difference between two forks::Devel::Symdump objects in human readable form. The format is similar to the one used by the as_string method. =item isa_tree =item inh_tree Isa_tree() and inh_tree() both return a simple string representation of the current inheritance tree. The difference between the two methods is the direction from which the tree is viewed: top-down or bottom-up. As I'm sure, many users will have different expectation about what is top and what is bottom, I'll provide an example what happens when the Socket module is loaded: =item % print forks::Devel::Symdump-Einh_tree AutoLoader DynaLoader Socket DynaLoader Socket Exporter Carp Config Socket The inh_tree method shows on the left hand side a package name and indented to the right the packages that use the former. =item % print forks::Devel::Symdump-Eisa_tree Carp Exporter Config Exporter DynaLoader AutoLoader Socket Exporter DynaLoader AutoLoader The isa_tree method displays from left to right ISA relationships, so Socket IS A DynaLoader and DynaLoader IS A AutoLoader. (Actually, they were at the time this manpage was written) =back You may call both methods, isa_tree() and inh_tree(), with an object. If you do that, the object will store the output and retrieve it when you call the same method again later. The typical usage would be to use them as class methods directly though. =head1 SUBCLASSING The design of this package is intentionally primitive and allows it to be subclassed easily. An example of a (maybe) useful subclass is forks::Devel::Symdump::Export, a package which exports all methods of the forks::Devel::Symdump package and turns them into functions. =head1 AUTHORS Andreas Koenig F<< >> and Tom Christiansen F<< >>. Based on the old F by Larry Wall. =head1 COPYRIGHT, LICENSE This is a modified version of Devel::Symdump 2.08. It includes custom patches for Perl 5.10 compatibiliy. Original module is Copyright (c) 1995, 1997, 2000, 2002, 2005, 2006 Andreas Koenig C<< >>. All rights reserved. This library is free software; you may use, redistribute and/or modify it under the same terms as Perl itself. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # End:forks-0.34/lib/forks/shared/0040755000076500000240000000000011405351363013664 5ustar gamesforks-0.34/lib/forks/shared/attributes.pm0100755000076500000240000000163411405321023016402 0ustar gamespackage forks::shared::attributes; #hide from PAUSE $VERSION = '0.34'; use Attribute::Handlers; # Required for perl < 5.8.0; 5.8+ corrects bug in attribute handling that # allowed internal 'shared' attribute to "slip" through and be passed to the # Attribute::Handler. package UNIVERSAL; #hide from PAUSE # Overload 'shared' attribute (required due to a bug in attributes < 0.7) sub shared : ATTR(VAR) { my ($package, $symbol, $referent, $attr, $data, $phase) = @_; $data = [ $data ] unless ref $data eq 'ARRAY'; threads::shared::_share( $referent ); } # Declare special attribute name to suppress warning: "Declaration of shared # attribute in package UNIVERSAL may clash with future reserved word" sub Forks_shared : ATTR(VAR) { my ($package, $symbol, $referent, $attr, $data, $phase) = @_; $data = [ $data ] unless ref $data eq 'ARRAY'; threads::shared::_share( $referent ); } 1; forks-0.34/lib/forks/shared/global_filter.pm0100755000076500000240000000412311405321023017015 0ustar gamespackage forks::shared::global_filter; # hide from PAUSE # Some internal magic to force source filtering on modules # Intended primarily for modules that aren't portable with perl < 5.8 use strict; use IO::File; use File::Spec; use List::MoreUtils; use vars '$VERSION'; $VERSION = '0.34'; our @FILTER = (); my @_dummy = (*ARGVOUT); sub import { my $class = shift; @FILTER = List::MoreUtils::uniq @FILTER, @_; unshift @INC, \&forks_filter; } sub do_filter { my ($module, $modfile) = @_; return unless grep {$module eq $_} @FILTER; my $file; local @INC = @INC; my $p; for my $path (@INC) { local @ARGV = File::Spec->catfile( $path, $modfile ); next unless -e $ARGV[0]; $file = do { local $/; <> } or return; $p = $ARGV[0]; } return unless $file; return if $module =~ m/^(forks|threads)\b/o; # Add use/require directive after each package declaration $file =~ s/(\bpackage[^;]+;)/$1 use forks; use forks::shared;\n/sgo; # Apply standard forks::shared source filter rules (for perl < 5.8) if ($] < 5.008) { $file =~ s#(\b(?:cond_wait)\b\s*(?!{)\(?\s*[^,]+,\s*)(?=[mo\$\@\%])#$1\\#sg; $file =~ s#(\b(?:cond_timedwait)\b\s*(?!{)\(?\s*[^,]+,[^,]+,\s*)(?=[mo\$\@\%])#$1\\#sg; $file =~ s#(\b(?:cond_broadcast|cond_wait|cond_timedwait|cond_signal|share|is_shared|threads::shared::_id|lock)\b\s*(?!{)\(?\s*)(?=[mo\$\@\%])#$1\\#sg; $file =~ s#((?:my|our)((?:\s|\()*[\$@%*]\w+(?:\s|\)|,)*)+\:\s*)\bshared\b#$1Forks_shared#sg; } return ($p, _fake_module_fh( $file )); } sub forks_filter { my ($code, $module) = @_; $module =~ s{/}{::}g; $module =~ s/\.pm$//; (my $modfile = $module) =~ s{::}{/}g; $modfile .= '.pm' unless $modfile =~ m/\.pm$/o; my ($path, $fh) = do_filter( $module, $modfile ); return unless $fh; $INC{$modfile} = $path; $fh->seek( 0, 0 ); return $fh; } sub _fake_module_fh { my $text = shift; my $fh = IO::File->new_tmpfile() or return; $fh->print( $text ); $fh->seek( 0, 0 ); return $fh; } 1; forks-0.34/lib/forks/shared.pm0100755000076500000240000011323111405351166014224 0ustar gamespackage forks::shared; # make sure CPAN picks up on forks::shared.pm $VERSION = '0.34'; use Config (); #--------------------------------------------------------------------------- # IN: 1 class # 2..N Hash of parameters to set sub set_deadlock_option { # Get the class # Get the options # Initialize variables for final option values # Set value for 'detect' option # Set value for 'period' option # Set value for 'resolve' option # Send settings to server my $class = shift; my %opts = @_; my ($detect, $period, $resolve, $signal); $detect = $opts{detect} ? 1 : 0; $period = $opts{period} + 0 if defined $opts{period}; $resolve = $opts{resolve} ? 1 : 0; threads::shared::_command( '_set_deadlock_option', $detect,$period,$resolve,$signal ); } package threads::shared; # but we're masquerading as threads::shared.pm # Make sure we have version info for this module # Compatibility with the standard threads::shared # Do everything by the book from now on BEGIN { $VERSION = '1.33'; $threads_shared = $threads_shared = 1; } use strict; use warnings; # At compile time # If forks is running in shadow mode # Fake that forks::shared.pm was really loaded (if not set already) # Elsif there seems to be a threads.pm loaded # Fake that threads::shared.pm was really loaded (if not set already) # Elsif there are (real) threads loaded # Die now indicating we can't mix them BEGIN { if (defined $INC{'threads.pm'} && $forks::threads_override) { $INC{'forks/shared.pm'} ||= $INC{'threads/shared.pm'} } elsif (defined $INC{'forks.pm'}) { $INC{'threads/shared.pm'} ||= $INC{'forks/shared.pm'}; } elsif (defined $INC{'threads.pm'} && !$forks::threads_override) { die( "Can not mix 'use forks::shared' with real 'use threads'\n" ); } } # Make sure we can die with lots of information # Make sure we can find out about blessed references correctly # Load some additional list utility functions use Carp (); use Scalar::Util qw(reftype blessed refaddr); use List::MoreUtils; # If forks.pm is loaded # Make sure we have a local copy of the base command handler on the client side # Else # Load the XS stuff # If we're running a perl older than 5.008 # Disable the cond_xxxx family and other exported routines, without prototypes # Else # Have share do nothing, just return the ref # Disable the cond_xxxx family and other exported routines if ($forks::threads || $forks::threads) { # twice to avoid warnings *_command = \&threads::_command; *is_shared = \&_id; } else { require XSLoader; XSLoader::load( 'forks',$forks::shared::VERSION ); no warnings 'redefine'; if ($] < 5.007003) { *share = *is_shared = *lock = *cond_signal = *cond_broadcast = *shared_clone = *cond_wait = *cond_timedwait = sub { undef }; } else { *share = sub (\[$@%]) { return $_[0] }; *is_shared = *lock = *cond_signal = *cond_broadcast = sub (\[$@%]) { undef }; *cond_wait = sub (\[$@%];\[$@%]) { undef }; *cond_timedwait = sub (\[$@%]$;\[$@%]) { undef }; *shared_clone = sub { undef }; } } # Clone detection logic # Ordinal numbers of shared variables being locked by this thread # Whether to retain existing variable content during tie to threads::shared::* modules # Local cache of self-referential circular references (pertie workaround): tied obj => REF # Reverse lookup of local thread cache of self-referential circular references # Thread-local cache of shared variable tied primitives our $CLONE = 0; our %LOCKED; our $CLONE_TIED = !eval {forks::THREADS_NATIVE_EMULATION()}; our %CIRCULAR; our %CIRCULAR_REVERSE; our %SHARED_CACHE; # If Perl 5.8 or later core doesn't include required internal hooks (possibly compiled out) # Force suppressed 'shared' attribute to surface as 'Forks_shared' in Core attributes.pm if ($] >= 5.0008 && !__DEF_PL_sharehook()) { require attributes; my $old = \&attributes::_modify_attrs; no warnings 'redefine'; *attributes::_modify_attrs = sub { my ($ref, @attr) = @_; return ($old->(@_), (grep(/^shared$/o, @attr) ? 'Forks_shared' : ())); }; } # If Perl core doesn't support the required internal hooks # Localize $WARNINGS to silence warning when overloading ATTR 'shared' # Load forks::shared::attributes to overload 'shared' attribute handling if ($] < 5.0008 || !__DEF_PL_sharehook()) { local $^W = 0; require forks::shared::attributes; } #--------------------------------------------------------------------------- # If we're running in a perl before 5.8.0, we need a source filter to change # all occurrences of # # share( $x ); # # to: # # share( \$x ); # # The same applies for most other exported threads::shared functions. # # We do this by conditionally adding the source filter functionality if we're # running in a versione before 5.8.0. # # We also will use a source filter to change all occurrences of # [my|our] [VAR | (VAR1, VAR2, ...])] : shared # to: # [my|our] [VAR | (VAR1, VAR2, ...])] : Forks_shared # to suppress some warnings in Perl before 5.8.0. my $filtering; # are we filtering source code? BEGIN { eval <<'EOD' if ($filtering = $] < 5.008 ); # need string eval ;-( use Filter::Util::Call (); # get the source filter stuff #--------------------------------------------------------------------------- # IN: 1 object (not used) # OUT: 1 status sub filter { # Initialize status # If there are still lines to read # Convert the line if there is any mention of our special subs # Return the status my $status; if (($status = Filter::Util::Call::filter_read()) > 0) { #warn $_ if # activate if we want to see changed lines s#(\b(?:cond_wait)\b\s*(?!{)\(?\s*[^,]+,\s*)(?=[mo\$\@\%])#$1\\#sg; #warn $_ if # activate if we want to see changed lines s#(\b(?:cond_timedwait)\b\s*(?!{)\(?\s*[^,]+,[^,]+,\s*)(?=[mo\$\@\%])#$1\\#sg; #warn $_ if # activate if we want to see changed lines s#(\b(?:cond_broadcast|cond_wait|cond_timedwait|cond_signal|share|is_shared|threads::shared::_id|lock)\b\s*(?!{)\(?\s*)(?=[mo\$\@\%])#$1\\#sg; #warn $_ if # activate if we want to see changed lines s#((?:my|our)((?:\s|\()*[\$@%*]\w+(?:\s|\)|,)*)+\:\s*)\bshared\b#$1Forks_shared#sg; } $status; } #filter EOD } #BEGIN # Satisfy require 1; #--------------------------------------------------------------------------- # standard Perl features #--------------------------------------------------------------------------- # IN: 1 class # 2..N subroutines to export (default: async only) sub import { # Lose the class # Add filter if we're filtering my $class = shift; Filter::Util::Call::filter_add( CORE::bless {},$class ) if $filtering; # Enable deadlock options, if requested if ((my $idx = List::MoreUtils::firstidx( sub { $_ eq 'deadlock' }, @_)) >= 0) { if (ref $_[$idx+1] eq 'HASH') { my (undef, $opts) = splice(@_, $idx, 2); $class->set_deadlock_option(%{$opts}); } else { splice(@_, $idx, 1); } } # Perform the export needed _export( scalar(caller()),@_ ); } #import BEGIN { # forks::shared and threads::shared share same import method # load set_deadlock_option into threads::shared namespace *forks::shared::import = *forks::shared::import = \&import; *set_deadlock_option = *set_deadlock_option = \&forks::shared::set_deadlock_option; } # Predeclarations for internal functions my ($make_shared); # Create a thread-shared clone of a complex data structure or object sub shared_clone { # Die unless arguments are correct if (@_ != 1) { Carp::croak('Usage: shared_clone(REF)'); } # Clone all shared data during this process # Return cloned result local $CLONE_TIED = 1; return $make_shared->(shift, {}); } # Used by shared_clone() to recursively clone # a complex data structure or object $make_shared = sub { my ($item, $cloned) = @_; # Just return the item if: # 1. Not a ref; # 2. Already shared; or # 3. Not running 'threads'. { no warnings 'uninitialized'; return $item if (! ref($item) || is_shared($item) || ! $threads::threads); } # Check for previously cloned references # (this takes care of circular refs as well) my $addr = refaddr($item); if (exists($cloned->{$addr})) { # Return the already existing clone return $cloned->{$addr}; } # Make copies of array, hash and scalar refs and refs of refs my $copy; my $ref_type = reftype($item); # Copy an array ref if ($ref_type eq 'ARRAY') { # Make empty shared array ref $copy = &share([]); # Add to clone checking hash $cloned->{$addr} = $copy; # Recursively copy and add contents push(@$copy, map { $make_shared->($_, $cloned) } @$item); } # Copy a hash ref elsif ($ref_type eq 'HASH') { # Make empty shared hash ref $copy = &share({}); # Add to clone checking hash $cloned->{$addr} = $copy; # Recursively copy and add contents foreach my $key (keys(%{$item})) { $copy->{$key} = $make_shared->($item->{$key}, $cloned); } } # Copy a scalar ref elsif ($ref_type eq 'SCALAR') { $copy = \do{ my $scalar = $$item; }; share($copy); # Add to clone checking hash $cloned->{$addr} = $copy; } # Copy of a ref of a ref elsif ($ref_type eq 'REF') { # Special handling for $x = \$x if ($addr == refaddr($$item)) { $copy = \$copy; share($copy); $cloned->{$addr} = $copy; } else { my $tmp; $copy = \$tmp; share($copy); # Add to clone checking hash $cloned->{$addr} = $copy; # Recursively copy and add contents $tmp = $make_shared->($$item, $cloned); } } else { Carp::croak("Unsupported ref type: ", $ref_type); } # If input item is an object, then bless the copy into the same class if (my $class = blessed($item)) { CORE::bless($copy, $class); } # Clone READONLY flag if ($] >= 5.008003) { if ($ref_type eq 'SCALAR') { if (Internals::SvREADONLY($$item)) { Internals::SvREADONLY($$copy, 1); } } if (Internals::SvREADONLY($item)) { Internals::SvREADONLY($copy, 1); } } return $copy; }; #--------------------------------------------------------------------------- # Purge the thread cache (to insure thread-local refaddr) # Increment the current clone value (mark this as a cloned version) sub CLONE { %CIRCULAR = (); %CIRCULAR_REVERSE = (); %SHARED_CACHE = (); $CLONE++; } #CLONE #--------------------------------------------------------------------------- # IN: 1 class for which to bless # 2 reference to hash containing parameters # 3 initial value of scalar # OUT: 1 instantiated object sub TIESCALAR { # Clone all shared data during this process # Return tied result local $CLONE_TIED = 1; shift->_tie( 'scalar',@_ ); } #TIESCALAR #--------------------------------------------------------------------------- # IN: 1 class for which to bless # 2 reference to hash containing parameters # OUT: 1 instantiated object sub TIEARRAY { shift->_tie( 'array',@_ ) } #TIEARRAY #--------------------------------------------------------------------------- # IN: 1 class for which to bless # 2 reference to hash containing parameters # OUT: 1 instantiated object sub TIEHASH { shift->_tie( 'hash',@_ ) } #TIEHASH #--------------------------------------------------------------------------- # IN: 1 class for which to bless # 2 reference to hash containing parameters # 3..N any parameters passed to open() # OUT: 1 instantiated object sub TIEHANDLE { shift->_tie( 'handle',@_ ) } #TIEHANDLE #--------------------------------------------------------------------------- # IN: 1 perltie thawed value # OUT: 1..N output parameters sub _tied_filter { # Obtain the reference to the variable # Create the reference type of that reference # Return immediately if this isn't a reference my $it = shift; my $ref = reftype $it; return $it unless $ref; # Obtain the object # Return immediately if isn't a threads::shared object (i.e. circular REF) my $object; if ($ref eq 'SCALAR') { $object = tied ${$it}; } elsif ($ref eq 'ARRAY') { $object = tied @{$it}; } elsif ($ref eq 'HASH') { $object = tied %{$it}; } elsif ($ref eq 'GLOB') { $object = tied *{$it}; } else { return $it; } return $it unless UNIVERSAL::isa($object, 'threads::shared'); # Get the ordinal # If we already have a cached copy of this object # Get the blessed class (if any) # Save this as the return value # Rebless local ref to insure its up-to-date with shared blessed state # Else # Cache this value # Return the (tied) value my $ordinal = $object->{'ordinal'}; if (exists $SHARED_CACHE{$ordinal}) { my $class = blessed($it); CORE::bless($SHARED_CACHE{$ordinal}, $class) if $class; $it = $SHARED_CACHE{$ordinal}; } else { $SHARED_CACHE{$ordinal} = $it; } return $it; } # Define generic perltie proxy methods for most scalar, array, hash, and handle events BEGIN { no strict 'refs'; foreach my $method (qw/BINMODE CLEAR CLOSE EOF EXTEND FETCHSIZE FILENO GETC OPEN POP PRINT PRINTF READ READLINE SCALAR SEEK SHIFT STORESIZE TELL UNSHIFT WRITE/) { #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2..N input parameters # OUT: 1..N output parameters *$method = sub { # Obtain the object # Obtain the subroutine name # Handle the command with the appropriate data and obtain the result # Return whatever seems appropriate my $self = shift; my $sub = $self->{'module'}.'::'.$method; my @result = map { ref($_) ? _tied_filter($_) : $_ } _command( '_tied',$self->{'ordinal'},$sub,@_ ); wantarray ? @result : $result[0]; } } } # Define perltie proxy methods for events used by a tied hash that use a hash key as first argument BEGIN { no strict 'refs'; foreach my $method (qw/DELETE EXISTS FIRSTKEY NEXTKEY/) { #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2..N input parameters # OUT: 1..N output parameters *$method = sub { # Obtain the object # Obtain the subroutine name # If we're a hash and the key is a code reference # Force key stringification, to insure remote server uses same key value as thread # Handle the command with the appropriate data and obtain the result # Return whatever seems appropriate my $self = shift; my $sub = $self->{'module'}.'::'.$method; if ($self->{'type'} eq 'hash' && ref($_[0]) eq 'CODE') { $_[0] = "$_[0]"; } my @result = map { ref($_) ? _tied_filter($_) : $_ } _command( '_tied',$self->{'ordinal'},$sub,@_ ); wantarray ? @result : $result[0]; } } } #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2..N input parameters # OUT: 1..N output parameters sub PUSH { # Obtain the object # Obtain the subroutine name # Handle the command with the appropriate data and obtain the result (using # evaluated array slice to insure shared scalar push value works, as push # doesn't evaluate values before pushing them on the stack) # Return whatever seems appropriate my $self = shift; my $sub = $self->{'module'}.'::PUSH'; my @result = map { ref($_) ? _tied_filter($_) : $_ } _command( '_tied',$self->{'ordinal'},$sub,map($_, @_) ); wantarray ? @result : $result[0]; } #PUSH #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2..N input parameters # OUT: 1..N output parameters sub STORE { # Obtain the object # Obtain the subroutine name # If this is a scalar and to-be stored value is a reference # Obtain the object # Die if the reference is not a threads::shared tied object my $self = shift; my $sub = $self->{'module'}.'::STORE'; my $val = $_[$self->{'type'} eq 'scalar' ? 0 : 1]; if (my $ref = reftype($val)) { my $object; if ($ref eq 'SCALAR') { $object = tied ${$val}; } elsif ($ref eq 'ARRAY') { $object = tied @{$val}; } elsif ($ref eq 'HASH') { $object = tied %{$val}; } elsif ($ref eq 'GLOB') { $object = tied *{$val}; } elsif ($ref eq 'REF') { $object = $val; } Carp::croak "Invalid value for shared scalar" unless defined $object && (ref($object) eq 'REF' || $object->isa('threads::shared')); } # If we're a hash and the key is a code reference # Force key stringification, to insure remote server uses same key value as thread if ($self->{'type'} eq 'hash' && ref($_[0]) eq 'CODE') { $_[0] = "$_[0]"; } # Handle the command with the appropriate data and obtain the result # Delete cached shared self-circular reference lookups, if exists and self is a tied scalar # Return whatever seems appropriate my @result = map { ref($_) ? _tied_filter($_) : $_ } _command( '_tied',$self->{'ordinal'},$sub,@_ ); delete $CIRCULAR_REVERSE{delete $CIRCULAR{$self}} if $self->{'type'} eq 'scalar' && exists $CIRCULAR{$self}; wantarray ? @result : $result[0]; } #STORE #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2..N input parameters # OUT: 1..N output parameters sub FETCH { # Obtain the object # Obtain the subroutine name # If we're a hash and the key is a code reference # Force key stringification, to insure remote server uses same key value as thread # Handle the command with the appropriate data and obtain the result # If this is a tied scalar and the remote value is a circular self-reference # Return cached shared self-circular reference, if exists # Store cached shared self-circular reference lookup # Store reverse reference -> cached shared self-circular reference lookup # (Note: this value is localized per thread, so the same shared self-circular # variable will return different is_shared() values in different threads # Return whatever seems appropriate my $self = shift; my $sub = $self->{'module'}.'::FETCH'; if ($self->{'type'} eq 'hash' && ref($_[0]) eq 'CODE') { $_[0] = "$_[0]"; } my @result = map { ref($_) ? _tied_filter($_) : $_ } _command( '_tied',$self->{'ordinal'},$sub,@_ ); if ($self->{'type'} eq 'scalar' && ref($result[0]) eq 'REF' && ref(${$result[0]}) eq 'REF') { #TODO: is this too simple? Do we need to contact remote process? Seems like we should at least do a refaddr equality check (on the remote process) to validate this is a self-circular reference return $CIRCULAR{$self} if exists $CIRCULAR{$self}; $CIRCULAR{$self} = $result[0]; $CIRCULAR_REVERSE{$result[0]} = $self; } wantarray ? @result : $result[0]; } #FETCH #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2..N input parameters # OUT: 1..N output parameters sub SPLICE { # Die now if running in thread emulation mode # Obtain the object # Obtain the subroutine name # Handle the command with the appropriate data and obtain the result # Return whatever seems appropriate Carp::croak('Splice not implemented for shared arrays') if eval {forks::THREADS_NATIVE_EMULATION()}; my $self = shift; my $sub = $self->{'module'}.'::SPLICE'; my @result = map { ref($_) ? _tied_filter($_) : $_ } _command( '_tied',$self->{'ordinal'},$sub,@_ ); wantarray ? @result : $result[0]; } #SPLICE #--------------------------------------------------------------------------- # IN: 1 instantiated object sub UNTIE { # Obtain the object # Return if we're not in the originating thread # Handle the command with the appropriate data my $self = shift; return if $self->{'CLONE'} != $CLONE; map { ref($_) ? _tied_filter($_) : $_ } _command( '_untie',$self->{'ordinal'} ); } #UNTIE #--------------------------------------------------------------------------- # IN: 1 instantiated object sub DESTROY { #currently disabled, as DESTROY method is not used by threads # Obtain the object # Return if we're not in the originating thread # Handle the command with the appropriate data # my $self = shift; # return if $self->{'CLONE'} != $CLONE; # map { ref($_) ? _tied_filter($_) : $_ } _command( '_tied',$self->{'ordinal'},$self->{'module'}.'::DESTROY' ); } #DESTROY #--------------------------------------------------------------------------- # internal subroutines #--------------------------------------------------------------------------- # IN: 1 namespace to export to # 2..N subroutines to export sub _export { # Obtain the namespace # Set the defaults if nothing specified # Allow for evil stuff # Export whatever needs to be exported my $namespace = shift().'::'; my @export = qw(share shared_clone is_shared lock cond_wait cond_timedwait cond_signal cond_broadcast); push @export, 'bless' if $threads::threads && $threads::threads; @export = @_ if @_; no strict 'refs'; *{$namespace.$_} = \&$_ foreach @export; } #_export #--------------------------------------------------------------------------- # IN: 1 base class with which to bless # 2 string to be concatenated to class for tie-ing # 3 reference to hash with parameters # 4..N any other values to be passed to tieing routine # OUT: 1 tied, blessed object sub _tie { # Obtain the class with which to bless with inside the "thread" # Obtain the type of variable to be blessed # Obtain hash with parameters or create an empty one my $class = shift; my $type = shift; my $self = shift || {}; # Make sure we can do clone detection logic # Set the type of variable to be blessed # Obtain the module name to be blessed inside the shared "thread" # Obtain the ordinal number for this tied variable (don't pass ref if running in threads emulation mode) # Create the blessed object and return it $self->{'CLONE'} = $CLONE; $self->{'type'} = $type; $self->{'module'} ||= $class.'::'.$type; $self->{'ordinal'} = _command( '_tie',$self,( $CLONE_TIED ? @_ : () ) ); CORE::bless $self,$class; } #_tie #--------------------------------------------------------------------------- # IN: 1 reference to variable to be shared sub _share { # Obtain the reference # Create the reference type of that reference my $it = shift; my $ref = reftype $it; # Tie the variable, or return already existing tied variable if ($ref eq 'SCALAR') { my $tied = tied ${$it}; return $tied if blessed($tied) && $tied->isa('threads::shared'); tie ${$it},'threads::shared',{},\${$it}; } elsif ($ref eq 'ARRAY') { my $tied = tied @{$it}; return $tied if blessed($tied) && $tied->isa('threads::shared'); tie @{$it},'threads::shared',{},\@{$it}; } elsif ($ref eq 'HASH') { my $tied = tied %{$it}; return $tied if blessed($tied) && $tied->isa('threads::shared'); tie %{$it},'threads::shared',{},\%{$it}; } elsif ($ref eq 'GLOB') { my $tied = tied *{$it}; return $tied if blessed($tied) && $tied->isa('threads::shared'); tie *{$it},'threads::shared',{},\*{$it}; } else { _croak( "Don't know how to share '$it'" ); } } #_share #--------------------------------------------------------------------------- # IN: 1 reference to variable sub __id { # Obtain the reference to the variable # Create the reference type of that reference # Dereference a REF or non-tied SCALAR reftype value # Return cached refaddress if this is a shared circular self-reference (perltie workaround) # Return immediately if this is not a valid reference # Initialize the object my $it = shift; my $ref = reftype $it; while ($ref && ($ref eq 'REF' || ($ref eq 'SCALAR' && !tied ${$it}))) { $it = ${$it}; $ref = reftype $it; if ($ref && $ref eq 'REF') { #possible self-circular reference return exists $CIRCULAR_REVERSE{$it} ? refaddr($CIRCULAR{$CIRCULAR_REVERSE{$it}}) : undef; } } return undef unless $ref; my $object; # Obtain the object if ($ref eq 'SCALAR') { $object = tied ${$it}; } elsif ($ref eq 'ARRAY') { $object = tied @{$it}; } elsif ($ref eq 'HASH') { $object = tied %{$it}; } elsif ($ref eq 'GLOB') { $object = tied *{$it}; } # If the reference is a threads::shared tied object # Get the ordinal of the variable # Return the global refaddr of the shared variable # Else # Return undef if (defined $object && $object->isa('threads::shared')) { my $ordinal = $object->{'ordinal'}; my $retval = _command( '_id',$ordinal ); return $retval; } else { return undef; } } #__id #--------------------------------------------------------------------------- # IN: 1 reference to variable sub _refcnt {} #_refcnt #--------------------------------------------------------------------------- # IN: 1..N ordinal numbers of variables to unlock sub _unlock { # For each ordinal number # Decrement the lock counter # Delete ordinal number from the local list, if counter is zero (lock released) # Notify the remote process also foreach (@_) { $LOCKED{$_}--; delete $LOCKED{$_} if $LOCKED{$_} <= 0; } _command( '_unlock',@_ ); } #unlock #--------------------------------------------------------------------------- # IN: 1 reference to the shared variable # OUT: 1 ordinal number of variable # 2 return value scalar of _command sub _bless { # Obtain the reference to the variable # Create the reference type of that reference # Initialize the object my $it = shift; my $ref = reftype $it; my $object; # If this package could CLONE_SKIP (don't execute now) # Cache the CLONE_SKIP method # Store a weak reference to this object my $package = $_[0]; if (my $code = exists( $threads::CLONE_SKIP{$package} ) ? $threads::CLONE_SKIP{$package} : eval { $package->can( 'CLONE_SKIP' ) }) { $threads::CLONE_SKIP{$package} = $code unless exists $threads::CLONE_SKIP{$package}; my $addr = refaddr $it; $threads::CLONE_SKIP_REF{$package}{$addr} = \$it; Scalar::Util::weaken(${$threads::CLONE_SKIP_REF{$package}{$addr}}); } # Obtain the object if ($ref eq 'SCALAR') { $object = tied ${$it}; } elsif ($ref eq 'ARRAY') { $object = tied @{$it}; } elsif ($ref eq 'HASH') { $object = tied %{$it}; } elsif ($ref eq 'GLOB') { $object = tied *{$it}; } # If the reference is a threads::shared tied object # Execute the indicated subroutine for this shared variable # Return the variable's ordinal number (and _command return scalar value if wantarray) if (defined $object && $object->isa('threads::shared')) { my $ordinal = $object->{'ordinal'}; my $retval = _command( '_bless',$ordinal,@_ ); return wantarray ? ($ordinal,$retval) : $ordinal; } } #_bless #--------------------------------------------------------------------------- # IN: 1 remote subroutine to call # 2 parameter of which a reference needs to be locked # OUT: 1 ordinal number of variable # 2 return value scalar of _command sub _remote { # Obtain the subroutine # Obtain the reference to the variable # Create the reference type of that reference # Initialize the object my $sub = shift; my $it = shift; my $ref = reftype $it; my $object; # Obtain the object if ($ref eq 'SCALAR') { $object = tied ${$it}; } elsif ($ref eq 'ARRAY') { $object = tied @{$it}; } elsif ($ref eq 'HASH') { $object = tied %{$it}; } elsif ($ref eq 'GLOB') { $object = tied *{$it}; } # If there is an ordinal number (if no object, there's no number either) # If we're about to lock # Mark the variable as locked in this thread # Store some caller() info (for deadlock detection report use) # Else if this is second case of _wait or _timedwait (unique signal and lock vars) # Obtain the reference to the lock variable (pop it off stack) # Create the reference type of that reference # Initialize the lock object # Obtain the lock object # If there is an ordinal number (if no object, there's no number either) # Die now if the variable does not appear to be locked # Push lock ordinal back on stack # Else (doing something on a locked variable) # Die now if the variable does not appear to be locked if (my $ordinal = $object->{'ordinal'}) { if ($sub eq '_lock') { $LOCKED{$ordinal}++; push @_, (caller())[2,1]; } elsif (($sub eq '_wait' && scalar @_ > 0) || ($sub eq '_timedwait' && scalar @_ > 1)) { my $it2 = pop @_; my $ref2 = reftype $it2; my $object2; if ($ref2 eq 'SCALAR') { $object2 = tied ${$it2}; } elsif ($ref2 eq 'ARRAY') { $object2 = tied @{$it2}; } elsif ($ref2 eq 'HASH') { $object2 = tied %{$it2}; } elsif ($ref2 eq 'GLOB') { $object2 = tied *{$it2}; } if (my $ordinal2 = $object2->{'ordinal'}) { Carp::croak( "You need a lock before you can cond$sub" ) if not exists $LOCKED{$ordinal2}; push @_, $ordinal2; } } else { if (not exists $LOCKED{$ordinal}) { if ($sub eq '_signal' || $sub eq '_broadcast') { warnings::warnif('threads', "cond$sub() called on unlocked variable"); } else { Carp::croak( "You need a lock before you can cond$sub" ); } } } # Execute the indicated subroutine for this shared variable # Return the variable's ordinal number (and _command return scalar value if wantarray) my $retval = _command( $sub,$ordinal,@_ ); return wantarray ? ($ordinal,$retval) : $ordinal; } # Adapt sub name to what we know outside # No ordinal found, not shared! Die! $sub = $sub eq '_lock' ? 'lock' : "cond$sub"; Carp::croak( "$sub can only be used on shared values" ); } #_remote #--------------------------------------------------------------------------- # debugging routines #--------------------------------------------------------------------------- # IN: 1 message to display sub _croak { return &Carp::confess(shift) } #_croak #--------------------------------------------------------------------------- __END__ =head1 NAME forks::shared - drop-in replacement for Perl threads::shared with forks() =head1 SYNOPSIS use forks; use forks::shared; my $variable : shared; my @array : shared; my %hash : shared; share( $variable ); share( @array ); share( %hash ); $variable = shared_clone($non_shared_ref_value); $variable = shared_clone({'foo' => [qw/foo bar baz/]}); lock( $variable ); cond_wait( $variable ); cond_wait( $variable, $lock_variable ); cond_timedwait( $variable, abs time ); cond_timedwait( $variable, abs time, $lock_variable ); cond_signal( $variable ); cond_broadcast( $variable ); bless( $variable, class name ); # Enable deadlock detection and resolution use forks::shared deadlock => { detect => 1, resolve => 1 ); # or threads::shared->set_deadlock_option( detect => 1, resolve => 1 ); =head1 DESCRIPTION The C pragma allows a developer to use shared variables with threads (implemented with the "forks" pragma) without having to have a threaded perl, or to even run 5.8.0 or higher. C is currently API compatible with CPAN L version C<1.05>. =head1 EXPORT C, C, C, C, C, C, C, C See L for more information. =head1 OBJECTS L exports a version of L that works on shared objects, such that blessings propagate across threads. See L for usage information and the L test suite for additional examples. =head1 EXTRA FEATURES =head2 Deadlock detection and resolution In the interest of helping programmers debug one of the most common bugs in threaded application software, forks::shared supports a full deadlock detection and resolution engine. =head3 Automated detection and resolution There are two ways to enable these features: either at import time in a use statement, such as: use forks::shared deadlock => { OPTIONS } or during runtime as a class method call to C, like: forks::shared->set_deadlock_option( OPTIONS ); #or threads::shared->set_deadlock_option( OPTIONS ); where C may be a combination of any of the following: detect => 1 (enable) or 0 (disable) period => number of seconds between asynchronous polls resolve => 1 (enable) or 0 (disable) The C option enables deadlock detection. By itself, this option enabled synchronous deadlock detection, which efficiently checks for potential deadlocks at lock() time. If any are detected and warnings are enabled, it will print out details to C like the following example: Deadlock detected: TID SV LOCKED SV LOCKING Caller 1 3 4 t/forks06.t at line 41 2 4 3 t/forks06.t at line 46 The C option, if set to a value greater than zero, is the number of seconds between asynchronous deadlock detection checks. Asynchronous detection is useful for debugging rare, time-critical race conditions leading to deadlocks that may be masked by the slight time overhead introduced by synchronous detection on each lock() call. Overall, it is less CPU intensive than synchronous deadlock detection. The C option enables auto-termination of one thread in each deadlocked thread pair that has been detected. As with the C option, C prints out the action it performs to STDERR, if warnings are enabled. B: C uses SIGKILL to break deadlocks, so this feature should not be used in environments where stability of the rest of your application may be adversely affected by process death in this manner. For example: use forks; use forks::shared deadlock => {detect=> 1, resolve => 1}; =head3 Manual detection If you wish to check for deadlocks without enabling automated deadlock detection, forks provides an additonal thread object method, $thr->is_deadlocked() that reports whether the thread in question is currently deadlocked. This method may be used in conjunction with the C deadlock option to auto-terminate offending threads. =head2 Splice on shared array As of at least L 1.05, the splice function has not been implememted for arrays; however, L fully supports splice on shared arrays. =head2 share() doesn't lose value for arrays and hashes In the standard Perl threads implementation, arrays and hashes are re-initialized when they become shared (with the share()) function. The share() function of forks::shared does B initialize arrays and hashes when they become shared with the share() function. This B be considered a bug in the standard Perl implementation. In any case this is an inconsistency of the behaviour of threads.pm and forks.pm. If you do not have a natively threaded perl and you have installed and are using forks in "threads.pm" override mode (where "use threads" loads forks.pm), then this module will explicitly emulate the behavior of standard threads::shared and lose value for arrays and hashes with share(). Additionally, array splice function will become a no-op with a warning. You may also enable this mode by setting the environment variable C to a true value before running your script. See L for more information. =head1 CAVIATS Some caveats that you need to be aware of. =over 2 =item Storing CODE refs in shared variables Since forks::shared requires Storable to serialize shared data structures, storing CODE refs in shared variables is not enabled by default (primarily for security reasons). If need share CODE refs between threads, the minimum you must do before storing CODE refs is: $Storable::Deparse = $Storable::Eval = 1; See L for detailed information, including potential security risks and ways to protect yourself against them. =item test-suite exits in a weird way Although there are no errors in the test-suite, the test harness sometimes thinks there is something wrong because of an unexpected exit() value. This is an issue with Test::More's END block, which wasn't designed to co-exist with a threads environment and forked processes. Hopefully, that module will be patched in the future, but for now, the warnings are harmless and may be safely ignored. =back =head1 CURRENT AUTHOR AND MAINTAINER Eric Rybski . Please send all module inquries to me. =head1 ORIGINAL AUTHOR Elizabeth Mattijsen, . =head1 COPYRIGHT Copyright (c) 2005-2010 Eric Rybski , 2002-2004 Elizabeth Mattijsen . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L. =cut forks-0.34/lib/forks/signals.pm0100755000076500000240000001236211405351166014421 0ustar gamespackage forks::signals; #hide from PAUSE $VERSION = '0.34'; use strict; use warnings; use Carp (); use vars qw($sig %usersig); use List::MoreUtils; use Sys::SigAction qw(set_sig_handler); # Declare private package variables my $tied; my %sig_undefined_map; my %sig_defined_map; my %is_sig_user_defined; sub import { shift; # Overload and tie %SIG unless ($sig) { %usersig = %SIG; $sig = \%SIG; *SIG = {}; $tied = tie %SIG, __PACKAGE__; } # Load wrapper subroutines and prepare %SIG for signals that were already defined. if ((my $idx = List::MoreUtils::firstidx( sub { $_ eq 'ifdef' }, @_)) >= 0) { if (ref $_[$idx+1] eq 'HASH') { my (undef, $opts) = splice(@_, $idx, 2); %sig_defined_map = map { $_ => $opts->{$_} } map(defined $opts->{$_} && $opts->{$_} ne '' ? $_ : (), keys %{$opts}); _STORE($_, $usersig{$_}) foreach map(defined $usersig{$_} && $usersig{$_} ne '' ? $_ : (), keys %sig_defined_map); } else { splice(@_, $idx, 1); %sig_defined_map = (); } } # Load wrapper subroutines and prepare %SIG for signals that were not already defined. if ((my $idx = List::MoreUtils::firstidx( sub { $_ eq 'ifndef' }, @_)) >= 0) { if (ref $_[$idx+1] eq 'HASH') { my (undef, $opts) = splice(@_, $idx, 2); %sig_undefined_map = map { $_ => $opts->{$_} } map(defined $opts->{$_} && $opts->{$_} ne '' ? $_ : (), keys %{$opts}); _STORE($_, (defined $usersig{$_} ? $usersig{$_} : undef)) foreach map(!defined $usersig{$_} || $usersig{$_} eq '' ? $_ : (), keys %sig_undefined_map); } else { splice(@_, $idx, 1); %sig_undefined_map = (); } } return $tied; } sub _STORE { my $k = shift; my $s = shift; my $flags; # Install or remove signal handler (including wrapper subroutine, when apporpriate) if (!defined($s) || $s eq '' || $s eq 'DEFAULT') { if (grep(/^$k$/, keys %sig_undefined_map)) { if (ref $sig_undefined_map{$k} eq 'ARRAY') { $sig->{$k} = $sig_undefined_map{$k}[0]; $flags = $sig_undefined_map{$k}[1]; } else { $sig->{$k} = $sig_undefined_map{$k}; } } else { delete( $sig->{$k} ); } delete( $is_sig_user_defined{$k} ); } elsif ($s eq 'IGNORE') { $sig->{$k} = 'IGNORE'; delete( $is_sig_user_defined{$k} ); } else { $sig->{$k} = ref($s) eq 'CODE' ? grep(/^$k$/, keys %sig_defined_map) ? sub { $sig_defined_map{$k}->(@_); $s->(@_) } : $s : grep(/^$k$/, keys %sig_defined_map) ? sub { $sig_defined_map{$k}->(@_); $s; } : $s; $is_sig_user_defined{$k} = 1; } # If subroutine signal handler has custom flags, apply them to the handler if possible. # Example: CHLD handler may have SA_RESTART flag, to minimize side effects with programs # that don't install a custom CHLD handler (very common) but use slow system signals; # programs that do install a custom CHLD handler. # Note: custom handler flags only currently applied to ifndef, as use with ifdef might # unexpectedly overwrite user flags, if user is using POSIX::sigaction to set signals. if (defined $flags && ref($sig->{$k}) eq 'CODE') { untie %SIG; set_sig_handler($k, $sig->{$k}, { flags => $flags, safe => $] < 5.008002 ? 0 : 1 }); tie %SIG, __PACKAGE__; } return $s; } # Package method returns wheter a user-defined handler is set for a given signal. # Input argument must be a signal name string, i.e. INT, TERM, CHLD, etc. sub is_sig_user_defined { return exists $is_sig_user_defined{$_[0]} ? $is_sig_user_defined{$_[0]} : 0; } sub CLONE {} sub TIEHASH { bless({}, shift) } sub UNTIE { my ($obj,$count) = @_; # Note: refcount of 1 unavoidable, likely due to how %SIG is internally referenced # in this module; however, anything larger indicates a potential issue. Carp::carp "untie attempted while $count inner references still exist" if $count > 1; } sub STORE { $usersig{$_[1]} = $_[2]; _STORE($_[1], $_[2]); } sub FETCH { $sig->{$_[1]} } sub FIRSTKEY { my $a = scalar keys %{$sig}; each %{$sig} } sub NEXTKEY { each %{$sig} } sub EXISTS { exists $sig->{$_[1]} } sub DELETE { _STORE($_[1], undef) } sub CLEAR { $_[0]->DELETE($_) while ($_) = each %{$sig}; return; } sub SCALAR { scalar %{$sig} } 1; __END__ =head1 NAME forks::signals - signal management for forks =head1 DESCRIPTION This module is only intended for internal use by L. =head1 CREDITS Implementation inspired by Cory Johns' L. =head1 AUTHOR Eric Rybski . Please send all module inquries to me. =head1 COPYRIGHT Copyright (c) 2005-2010 Eric Rybski . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L =cut forks-0.34/lib/forks.pm0100755000076500000240000046321611405351166012771 0ustar gamespackage forks; # make sure CPAN picks up on forks.pm $VERSION = '0.34'; # Allow external modules to defer shared variable init at require $DEFER_INIT_BEGIN_REQUIRE = 0 unless $DEFER_INIT_BEGIN_REQUIRE; package threads; # but in fact we're masquerading as threads.pm # Make sure we have version info for this module # Set flag to indicate that we're really the original threads implementation # Set flag to indicate that we're not really the original threads implementation # Flag whether or not module is loaded in namespace override mode (e.g. threads.pm) # Be strict from now on BEGIN { $VERSION = '1.77'; $threads = $threads = 1; # twice to avoid warnings $forks::threads = $forks::threads = 1; # twice to avoid warnings $forks::threads_override = $forks::threads_override = 0; # twice to avoid warnings } # Standard forks behavior (extra features), or emulate threads to-the-letter BEGIN { if ($forks::threads_override) { $forks::threads_native_emulation = 1; } elsif (exists $ENV{'THREADS_NATIVE_EMULATION'}) { $ENV{'THREADS_NATIVE_EMULATION'} =~ m#^(.*)$#s; $forks::threads_native_emulation = $1 ? 1 : 0; } else { $forks::threads_native_emulation = 0; } *forks::THREADS_NATIVE_EMULATION = sub { $forks::threads_native_emulation }; } # Use strict pragma # Use warnings pragma # Register 'threads' namespace with warnings (if not already present) # Make sure we can die with lots of information use strict; use warnings; use warnings::register; use Carp (); #--------------------------------------------------------------------------- # Set when to execute check and end blocks BEGIN { if ($^C) { eval "CHECK { _CHECK() }"; } elsif (defined &DB::DB) { # TODO: no end block for now, as debugger halts on it (ignoring $DB::inhibit_exit) } else { $] < 5.008 ? eval "END { eval{ _END() } }" : eval "END { _END() }"; } } #BEGIN # Fake that threads.pm was really loaded, before loading any other modules BEGIN { my $module = 'forks'; if (defined $INC{'forks.pm'}) { $INC{'threads.pm'} ||= $INC{'forks.pm'}; } elsif (defined $INC{'threads.pm'} && $forks::threads_override) { $module = 'threads'; $INC{'forks.pm'} ||= $INC{'threads.pm'} } elsif (defined $INC{'threads.pm'} && !$forks::threads_override) { die( "Can not mix 'use forks' with real 'use threads'" ) } $module = 'threads' if eval{forks::THREADS_NATIVE_EMULATION()}; Carp::carp "Warning, $module\::shared has already been loaded" if defined $INC{'forks/shared.pm'}; } # Load signal handler libraries BEGIN { require sigtrap; require forks::signals; } # Import additional scalar methods for refs and objects # Load library to set temp dir for forks data # Load library that to support unblessing objects use Scalar::Util qw(reftype blessed refaddr); use File::Spec; use forks::Devel::Symdump; # Perl 5.10.x patch for Devel::Symdump 2.08 use Acme::Damn (); # Set constant for IPC temp dir # Set constant for IPC temp thread signal notifications use constant ENV_ROOT => File::Spec->tmpdir().'/perlforks'; use constant ENV_SIGNALS => ENV_ROOT.'/signals'; # Set constants for threads->list() operations: all, running, and joinable use constant all => (); use constant running => 1; use constant joinable => 0; # Set constants for threads exit use constant EXIT_THREAD_ONLY => 'thread_only'; use constant EXIT_THREADS_ONLY => 'threads_only'; # (bug?) Perl 5.11+ each function may not correctly set hash iterator when using refs as keys use constant RESET_EACH_ITER => $] >= 5.011; #--------------------------------------------------------------------------- # Modify Perl's Config.pm to simulate that it was built with ithreads BEGIN { require Config; my $h = tied %Config::Config; $h->{useithreads} = 1; } #--------------------------------------------------------------------------- # Global debug flag # Global socket server Nice value # Global CHLD force IGNORE flag # Global UNIX socket flag # Global INET socket IP mask regex value # Do this at compile time # If there is a THREADS_DEBUG specification # Untaint value # Set its value # Make sure access is done with the DEBUG sub # Else (we never need any debug info) # Make DEBUG a false constant: debugging code should be optimised away # If there is a THREADS_SOCKET_UNIX specification # Set its value # Make sure socket is available; die if non-socket object exists # Remove existing socket file if defined # Make sure access is done with the THREADS_UNIX sub # Else # Make THREADS_UNIX a false constant: default to INET sockets # If there is a THREADS_IP_MASK specification # Set its value # Else # Use default localhost mask # If there is a THREADS_DAEMON_MODEL specification # Enable integrated threads (server process child of main thread) # Else # Enable normal threads (server process parent of main thread) # If there is a PERL5_ITHREADS_STACK_SIZE specification # Set this as the new default size # Else # Set to the system default size (0 == use system default) my $DEBUG; my $SERVER_NICE; my $FORCE_SIGCHLD_IGNORE; my $THREADS_UNIX; my $INET_IP_MASK; my $THREADS_INTEGRATED_MODEL; my $ITHREADS_STACK_SIZE; BEGIN { if (exists $ENV{'THREADS_DEBUG'}) { $ENV{'THREADS_DEBUG'} =~ m#^(.*)$#s; $DEBUG = $1; } else { $DEBUG = 0; } *DEBUG = sub () { $DEBUG }; if (exists $ENV{'THREADS_NICE'}) { $ENV{'THREADS_NICE'} =~ m#^(.*)$#s; $SERVER_NICE = $1; } else { $SERVER_NICE = 0; } if (exists $ENV{'THREADS_SIGCHLD_IGNORE'}) { $ENV{'THREADS_SIGCHLD_IGNORE'} =~ m#^(.*)$#s; $FORCE_SIGCHLD_IGNORE = $1; } else { $FORCE_SIGCHLD_IGNORE = 0; } my $threads_socket_unix = '/var/tmp/perlforks.'; if (defined $ENV{'THREADS_SOCKET_UNIX'} && $ENV{'THREADS_SOCKET_UNIX'} ne "") { #$ENV{'THREADS_SOCKET_UNIX'} =~ m#^(.*)$#s; $THREADS_UNIX = $threads_socket_unix; } else { $THREADS_UNIX = 0; } if (exists $ENV{'THREADS_IP_MASK'}) { $ENV{'THREADS_IP_MASK'} =~ m#^(.*)$#s; $INET_IP_MASK = $1; } else { $INET_IP_MASK = '^127\.0\.0\.1$'; } if (exists $ENV{'THREADS_DAEMON_MODEL'}) { $ENV{'THREADS_DAEMON_MODEL'} =~ m#^(.*)$#s; $THREADS_INTEGRATED_MODEL = $1 ? 0 : 1; } else { $THREADS_INTEGRATED_MODEL = 1; } if (exists $ENV{'PERL5_ITHREADS_STACK_SIZE'}) { $ENV{'PERL5_ITHREADS_STACK_SIZE'} =~ m#^(\d+)$#s; $ITHREADS_STACK_SIZE = $1; } else { $ITHREADS_STACK_SIZE = 0; } } #BEGIN # Load the XS stuff require XSLoader; XSLoader::load( 'forks',$forks::VERSION ); # Make sure we can do sockets and have the appropriate constants # Make sure we can do select() on multiple sockets # Make sure we have the necessary POSIX constants # Make sure that we can freeze and thaw data structures # Allow for chainable child reaping functions # Enable hi-res time use Socket qw(SOMAXCONN); use IO::Socket (); use IO::Select (); use POSIX qw(WNOHANG BUFSIZ O_NONBLOCK F_GETFL F_SETFL SIG_BLOCK SIG_UNBLOCK SIGCHLD SIGKILL ECONNABORTED ECONNRESET EAGAIN EINTR EWOULDBLOCK ETIMEDOUT SA_RESTART SA_NOCLDSTOP WIFEXITED WIFSIGNALED); use Storable (); use Time::HiRes qw(time); use List::MoreUtils; # Flag whether or not forks has initialized the server process # Thread local query server object # The port on which the thread server is listening # The process id in which the shared variables are stored # The main thread process id # Initialize thread local hash (key: pid) whether this process is a thread # Initialize local flag whether main thread received ABRT signal # Initialize local flag whether main thread exited due to ABRT signal # Initialize local flag whether main thread should be signalled with ABRT on server shutdown # Initialize hash (key: pid) of child thread PIDs # Thread local flag whether we're shutting down # Thread local flag whether we're shutting down in END block # Thread local flag whether we're shut down my $HANDLED_INIT = 0; my $QUERY; my $PORT; my $SHARED; my $PID_MAIN_THREAD; my %ISATHREAD; my $MAIN_ABRT_HANDLED = 0; my $MAIN_EXIT_WITH_ABRT = 0; my $MAIN_EXIT_NO_ABRT = 0; my %CHILD_PID; my $SHUTTING_DOWN = 0; my $SHUTTING_DOWN_END = 0; my $SHUTDOWN = 0; # Initialize the flag that indicates that we're still running # Initialize value that stores the desired application exit value # Initialize the number of bytes to read at a time # List of signals that forks intelligently monitors and traps to insure inter-thread signal stability # Initialize hash (key: sig name) of base not-defined signal behavior to use with forks::signals # Initialize hash (key: sig name) of base defined signal behavior to use with forks::signals # Pseudo-signal mask indicating signals to handle when thread finished current server message handling # Initialize flag that indicates whether thread is send data with shared process # Initialize flag that indicates whether thread is recv data with shared process # Initialize variable for shared server received data # Boolean indicating whether or not platform requires a custom CHLD handler # Max sleep time of main server loop before looping once # Initialize hash (key: client) with info to be written to client threads # Initialize hash (key: client) with clients that we're done with # Initialize the "thread local" thread id # Initialize the pid of the thread # Return context of thread (possible values are same as those of CORE::wantarray) # Initialize hash (key: package) with code references of CLONE subroutines # Initialize hash (key: package) with code references of CLONE_SKIP subroutines # Initialize hash (key: package) with object references for CLONE_SKIP-enabled classes my $RUNNING = 1; my $EXIT_VALUE; my $BUFSIZ = BUFSIZ; my @TRAPPED_SIGNAL; BEGIN { foreach my $signal (qw(HUP INT PIPE TERM USR1 USR2 ABRT EMT QUIT TRAP)) { push @TRAPPED_SIGNAL, $signal if grep(/^$signal$/, split(/\s+/, $Config::Config{sig_name})); } } my %THR_UNDEFINED_SIG = map { $_ => \&_sigtrap_handler_undefined } @TRAPPED_SIGNAL; my %THR_DEFINED_SIG = map { $_ => \&_sigtrap_handler_defined } @TRAPPED_SIGNAL; my @DEFERRED_SIGNAL = (); $threads::SEND_IN_PROGRESS = 0; $threads::RECV_IN_PROGRESS = 0; $threads::RECV_DATA = ''; my $CUSTOM_SIGCHLD = 0; my $MAX_POLL_SLEEP = 60; #seconds my %WRITE; my %DONEWITH; my $TID; my $PID; my $THREAD_CONTEXT; my %CLONE; our %CLONE_SKIP; our %CLONE_SKIP_REF; # Initialize the next thread ID to be issued # Initialize hash (key: tid) with the thread id to client object translation # Initialize hash (key: client) with the client object to thread id translation # Initialize hash (key: tid) with the thread id to process id translation # Initialize hash (key: pid) with the process id to thread id translation # Initialize hash (key: ppid) with the parent pid to child tid queue (value: array ref) # Initialize hash (key: tid) with the thread id to thread join context translation # Initialize hash (key: tid) with the thread id to thread stack size translation my $NEXTTID = 0; my %TID2CLIENT; my %CLIENT2TID; my %TID2PID; my %PID2TID; my %PPID2CTID_QUEUE; my %TID2CONTEXT; my %TID2STACKSIZE; # Initialize flag with global thread exit method (1=thread; 0=check %THREAD_EXIT) # Initialize hash (key: tid) with threads that should threads->exit() on exit() # Initialize scalar with tid's (comma-separated) that have been detached # Initialize hash (key: tid) with detached threads are still running # Initialize hash (key: tid) with results from threads # Initialize hash (key: tid) with terminal errors from threads # Initialize hash (key: tid) with threads that have not yet been joined my $THREADS_EXIT = 0; my %THREAD_EXIT; my $DETACHED = ''; my %DETACHED_NOTDONE; my %RESULT; my %ERROR; my %NOTJOINED; # Initialize hash (key: ppid) with clients blocking of ppid->ctid conversion # Initialize hash (key: tid) with clients blocking for join() result # Initialize period (seconds) of BLOCKING_JOIN check (abnormal thread death protection) # Initialize time of next BLOCKING_JOIN check my %BLOCKING_PPID2CTID_QUEUE; my %BLOCKING_JOIN; my $BLOCKING_JOIN_CHECK_PERIOD = 15; my $BLOCKING_JOIN_CHECK_TS_NEXT = 0; # Initialize hash (key: fq sub) with code references to tie subroutines # List with objects of shared (tied) variables # Ordinal number of next shared (tied) variable my %DISPATCH; my @TIED; my $NEXTTIED = 1; # Initialize list (key: ordinal) of threads that have the lock for a variable # Initialize hash (key: ordinal) of TID caller information from the (non-recursive) lock() # Initialize list (key: ordinal) of threads that have a recursive lock # Initialize list (key: ordinal) of threads that want to lock a variable # Initialize list (key: ordinal) of threads are waiting in cond_wait # Initialize hash (key: ordinal) of threads are waiting in cond_timedwait # Initialize scalar representing unique ID of each timed event # Initialize list (order: expiration time) representing a sorted version (pseudo-index) of %TIMEDWAITING # Initialize scalar indicating when %TIMEDWAITING has changed and @TIMEDWAITING_IDX should be recalculated # Initialize list (key: ordinal; subkey: tid) of TIMEDWAITING events that have timed out my @LOCKED; my %TID2LOCKCALLER; my @RECURSED; my @LOCKING; my @WAITING; my %TIMEDWAITING; my $TIMEDWAITING_ID = 0; my @TIMEDWAITING_IDX; my $TIMEDWAITING_IDX_EXPIRED = 0; my @TIMEDWAITING_EXPIRED; # Initialize hash (key: tid, value=signal) with clients to send sigals to my %TOSIGNAL; # Flag indicating whether deadlock detection enabled (default: disabled) # Deadlock detection period (0 => sync detection; else async detect every N sec) # Time of next deadlock detection event, if in asynchronous mode # Initialize hash (key: tid; value: tid of blocker) with clients that are deadlocked # Flag of whether server should terminate one thread of each deadlocked thread pair # Signal to use to kill deadlocked processes my $DEADLOCK_DETECT = 0; my $DEADLOCK_DETECT_PERIOD = 0; my $DEADLOCK_DETECT_TS_NEXT = 0; my %DEADLOCKED; my $DEADLOCK_RESOLVE = 0; my $DEADLOCK_RESOLVE_SIG = SIGKILL; # Create packed version of undef # Create packed version of zero-length string # Create packed version of false # Create packed version of true # Create packed version of empty list my $undef = _pack_response( [undef], ); my $defined = _pack_response( [''], ); my $false = _pack_response( [0], '__boolean' ); my $true = _pack_response( [1], '__boolean' ); my $empty = _pack_response( [], ); # Miscellaneous command-related constants # Command filters (closures) for optimized request/response handling my %cmd_filter; my @cmd_filtered; my @cmd_num_to_filter; my @cmd_num_to_type; my %cmd_type_to_num; BEGIN { use constant CMD_FLTR_REQ => 0; use constant CMD_FLTR_RESP => 1; use constant CMD_FLTR_ENCODE => 0; use constant CMD_FLTR_DECODE => 1; use constant CMD_TYPE_DEFAULT => 0; #entire content is frozen use constant CMD_TYPE_INTERNAL => 1; #msg has a custom filter use constant MSG_LENGTH_LEN => 4; use constant CMD_TYPE_IDX => 0; use constant CMD_TYPE_LEN => 1; use constant CMT_TYPE_FROZEN_CONTENT_IDX => 1; use constant CMD_TYPE_INTERNAL_SUBNAME_IDX => 1; use constant CMD_TYPE_INTERNAL_SUBNAME_LEN => 2; use constant CMD_TYPE_INTERNAL_CONTENT_IDX => 3; %cmd_filter = ( #pack: 1 arrayref input param; unpack: 1 scalar input param; pack/unpack: list output __boolean => [ #client-to-server [ #request sub { $_[0]->[0] ? '1' : '0'; }, #pack sub { $_[0]; } #unpack ], [ #response sub { $_[0]->[0] ? '1' : '0'; }, #pack sub { $_[0]; } #unpack ], ], ); %cmd_filter = ( #pack: 1 arrayref input param; unpack: 1 scalar input param; pack/unpack: list output %cmd_filter, _lock => [ #client-to-server [ #request sub { pack('IIa*', @{$_[0]}[0..2]); }, #pack sub { unpack('IIa*', $_[0]); } #unpack ], $cmd_filter{__boolean}->[CMD_FLTR_RESP] #response ], _unlock => [ #client-to-server [ #request sub { pack('I', $_[0]->[0]); }, #pack sub { unpack('I', $_[0]); } #unpack ], $cmd_filter{__boolean}->[CMD_FLTR_RESP] #response ], ); @cmd_filtered = sort { lc($a) cmp lc($b) } keys %cmd_filter; for (my $i = 0; $i < scalar @cmd_filtered; $i++) { $cmd_num_to_filter[$i] = $cmd_filter{$cmd_filtered[$i]}; $cmd_num_to_type[$i] = $cmd_filtered[$i]; $cmd_type_to_num{$cmd_filtered[$i]} = $i; } } #BEGIN # Make sure that equality works on thread objects use overload '==' => \&equal, '!=' => \&nequal, 'fallback' => 1, ; # Keep reference to pre-existing exit function my $old_core_global_exit; BEGIN { $old_core_global_exit = sub { CORE::exit(@_) }; } # Create new() -> create() equivalence # Initialize thread server at runtime, in case import was skipped *create = \&new; create() if 0; # to avoid warning _init() unless $forks::DEFER_INIT_BEGIN_REQUIRE; # Functions to allow external modules an API hook to specific runtime states # These may be used to build a new CORE::GLOBAL::fork state # General rule is that forks.pm will never define anything but CORE::fork # in _fork function, so this is the function to overload if you must # completely handle the core fork event; otherwise, all other methods # should be referenced and called like: # my $_old_fork_post_child = \&threads::_fork_post_child; # *threads::_fork_post_child = sub { # $_old_fork_post_child->(); # ... # } # when building a new CORE::GLOBAL::fork state. # See forks.pm CORE::GLOBAL::fork definition as an example. # Block all process signals when forking, to insure most stable behavior. my $_fork_block_sigset; BEGIN { $_fork_block_sigset = POSIX::SigSet->new(); $_fork_block_sigset->fillset(); } sub _fork_pre { # Block all signals during fork to prevent interruption POSIX::sigprocmask(SIG_BLOCK, $_fork_block_sigset); } #_fork_pre sub _fork { return CORE::fork; } #_fork sub _fork_post_parent { # Restore signals blocked during fork POSIX::sigprocmask(SIG_UNBLOCK, $_fork_block_sigset); } #_fork_post_parent sub _fork_post_child { # Restore signals blocked during fork # Reset some important state variables # Reset CORE::GLOBAL::exit(); will be redefined in _init_thread POSIX::sigprocmask(SIG_UNBLOCK, $_fork_block_sigset); delete $ISATHREAD{$$}; undef( $TID ); undef( $PID ); { no warnings 'redefine'; *CORE::GLOBAL::exit = $old_core_global_exit; } } #_fork_post_child # Overload global fork for best protection against external fork. BEGIN { no warnings 'redefine'; *CORE::GLOBAL::fork = *CORE::GLOBAL::fork = sub { # Perform the fork # Handle post-fork in parent and child processes, if fork was successful # Return the forked pid _fork_pre(@_); my $pid = _fork(@_); if (defined $pid) { if ($pid == 0) { #in child _fork_post_child(@_); } else { _fork_post_parent(@_); } } return $pid; }; } #BEGIN # Overload global, Time::HiRes sleep functions to reduce CHLD signal side-effects # Define flag toggled when REAPER has been called but user hasn't defined handler our $IFNDEF_REAPER_CALLED = 0; BEGIN { no warnings 'redefine'; # Store Time::HiRes sleep function for internal use my $proto = prototype 'CORE::sleep'; my $sleep = *sleep = *sleep = \&Time::HiRes::sleep; my $sub = sub { # Get requested sleep time # Initialize a few variables # Localize signal indicator for use only for this system call # While sleep time hasn't yet been exhausted # Calculate remaining sleep time # Reset signal indicator # Sleep and store total time slept # Exit loop if sleep exited for some reason other than a CHLD signal # Return total time slept my $s = shift; my $t = 0; my $f = 0; my $sig; local $IFNDEF_REAPER_CALLED; while ($s - $t > 0) { $s -= $t; $IFNDEF_REAPER_CALLED = 0; $f += $t = $sleep->($s); last unless $IFNDEF_REAPER_CALLED; } return sprintf("%.0f", $f); }; Scalar::Util::set_prototype(\&{$sub}, $proto); *CORE::GLOBAL::sleep = *CORE::GLOBAL::sleep = $sub; # Generate same function wrapper for Time::HiRes sleep, usleep, and nanosleep. # For usleep and nanosleep, only overload if they are defined. $proto = prototype 'Time::HiRes::sleep'; $sub = sub { my $s = shift; my $t = 0; my $f = 0; my $sig; local $IFNDEF_REAPER_CALLED; while ($s - $t > 0) { $s -= $t; $IFNDEF_REAPER_CALLED = 0; $f += $t = $sleep->($s); last unless $IFNDEF_REAPER_CALLED; } return $f; }; Scalar::Util::set_prototype(\&{$sub}, $proto); *Time::HiRes::sleep = *Time::HiRes::sleep = $sub; if (&Time::HiRes::d_usleep && defined(my $t = eval { Time::HiRes::usleep(0) }) && !$@) { $proto = prototype 'Time::HiRes::usleep'; my $usleep = \&Time::HiRes::usleep; $sub = sub { my $s = shift; my $t = 0; my $f = 0; my $sig; local $IFNDEF_REAPER_CALLED; while ($s - $t > 0) { $s -= $t; $IFNDEF_REAPER_CALLED = 0; $f += $t = $usleep->($s); last unless $IFNDEF_REAPER_CALLED; } return $f; }; Scalar::Util::set_prototype(\&{$sub}, $proto); *Time::HiRes::usleep = *Time::HiRes::usleep = $sub; } if (&Time::HiRes::d_nanosleep && defined(my $t = eval { Time::HiRes::nanosleep(0) }) && !$@) { $proto = prototype 'Time::HiRes::nanosleep'; my $nanosleep = \&Time::HiRes::nanosleep; $sub = sub { my $s = shift; my $t = 0; my $f = 0; my $sig; local $IFNDEF_REAPER_CALLED; while ($s - $t > 0) { $s -= $t; $IFNDEF_REAPER_CALLED = 0; $f += $t = $nanosleep->($s); last unless $IFNDEF_REAPER_CALLED; } return $f; }; Scalar::Util::set_prototype(\&{$sub}, $proto); *Time::HiRes::nanosleep = *Time::HiRes::nanosleep = $sub; } } #BEGIN #--------------------------------------------------------------------------- # class methods #--------------------------------------------------------------------------- # IN: 1 class # 2 subroutine reference of sub to start execution with # 3..N any parameters to be passed # OUT: 1 instantiated object sub new { # Obtain the class # Obtain the subroutine reference # Initialize some local vars # Parse stack_size of this object (if new called with object reference) # If sub is a hash ref # Assume thread-specific params were defined # Obtain the actual subroutine # Parse stack_size # Parse thread context (presidence given to param over implicit context) # Parse thread exit behavior # Else # Store implicit thread context my $class = shift; my $sub = shift; my ($param, $stack_size, $thread_context, $thread_exit); if (ref($class) && defined( my $size = $class->get_stack_size )) { $stack_size = $size; } if (ref($sub) eq 'HASH') { $param = $sub; $sub = shift; if (exists $param->{'stack_size'} && defined $param->{'stack_size'}) { $stack_size = $param->{'stack_size'}; } if (exists $param->{'stack'} && defined $param->{'stack'}) { $stack_size = $param->{'stack'}; } if ((exists $param->{'context'} && $param->{'context'} =~ m/^list|array$/o) || (exists $param->{'list'} && $param->{'list'} || (exists $param->{'array'} && $param->{'array'}))) { $thread_context = 1; } elsif ((exists $param->{'context'} && $param->{'context'} eq 'scalar') || (exists $param->{'scalar'} && $param->{'scalar'})) { $thread_context = 0; } elsif ((exists $param->{'context'} && $param->{'context'} eq 'void') || (exists $param->{'void'} && $param->{'void'})) { $thread_context = undef; } else { $thread_context = CORE::wantarray; } if (exists $param->{'exit'}) { if ($param->{'exit'} eq EXIT_THREAD_ONLY) { $thread_exit = EXIT_THREAD_ONLY; } elsif ($param->{'exit'} eq EXIT_THREADS_ONLY) { $thread_exit = EXIT_THREADS_ONLY; } } } else { $thread_context = CORE::wantarray; } # If it is not a code ref yet (other refs will bomb later) # Make the subroutine fully qualified if it is not yet # Turn the name into a reference unless (ref($sub)) { $sub = caller().'::'.$sub unless $sub =~ m#::#; $sub = \&{$sub}; } # Initialize the process id of the thread # Get results of _run_CLONE_SKIP # If it seems we're in the child process # If the fork failed # Print a detailed warning # Return undefined to indicate the failure my $pid; my $clone_skip = _run_CLONE_SKIP(); unless ($pid = fork) { unless (defined( $pid )) { warnings::warnif("Thread creation failed: Could not fork child from pid $$, tid $TID: ".($! ? $! : '')); return undef; } # Set up the connection for handling queries # Set appropriate thread exit behavior # If thread context is defined # If context is list # Execute the routine that we're supposed to execute (list context) # Else # Execute the routine that we're supposed to execute (scalar context) # Else # Execute the routine that we're supposed to execute (void context) # Print warning if thread terminated abnormally (if not main thread) # Mark this thread as shutting down # Save the result # And exit the process _init_thread($clone_skip, $thread_context, undef, $stack_size); if (defined($thread_exit) && $thread_exit eq EXIT_THREAD_ONLY) { threads->set_thread_exit_only(1); } elsif (defined($thread_exit) && $thread_exit eq EXIT_THREADS_ONLY) { _command( '_set_threads_exit_only',1 ); } my @result; my $error; if (defined $thread_context) { if ($thread_context) { eval { @result = $sub->( @_ ); }; } else { eval { $result[0] = $sub->( @_ ); }; } } else { eval { $sub->( @_ ); }; } #warn "$TID: context = ".(defined $thread_context ? $thread_context ? 'array' : 'scalar' : 'void').",result (".scalar(@result).")=".CORE::join(',',@result); #TODO: for debugging only if ($@) { $error = $@; warn "Thread $TID terminated abnormally: $@" if $TID && warnings::enabled(); } $SHUTTING_DOWN = 1; _command( '_tojoin',$error,@result ); CORE::exit(); } # Mark PID for reaping, if using custom CHLD signal handler # Obtain the thread id from the thread just started # Create an object for it and return it $CHILD_PID{$pid} = undef; my ($tid) = _command( '_waitppid2ctid',$$ ); $class->_object( $tid,$pid ); } #new #--------------------------------------------------------------------------- sub isthread { # Die now if this process is already marked as a thread # Set up stuff so this process is now a detached thread # Mark this thread as a detached thread (and run clone skip, even though we're not in parent) _croak( "Process $$ already registered as a thread" ) if exists( $ISATHREAD{$$} ); _init_thread( _run_CLONE_SKIP(), undef, 1 ); } #isthread #--------------------------------------------------------------------------- # IN: 1 class (ignored) # 2 new value of debug flag (optional) # OUT: 1 current value of debug flag sub debug { $DEBUG = $_[1] if @_ > 1; $DEBUG } #debug #--------------------------------------------------------------------------- # IN: 1 class or instantiated object # OUT: 1 thread id sub tid { # Obtain the object # Return the thread local tid if called as a class method # Return the field in the object, or fetch and set and return that my $self = shift; return $TID unless ref($self); $self->{'tid'} ||= _command( '_pid2tid',$self->{'pid'} ); } #tid #--------------------------------------------------------------------------- # IN: 1 class (ignored) # OUT: 1 instantiated object sub self { shift->_object( $TID,$$ ) } #self #--------------------------------------------------------------------------- # IN: 1 class (ignored) # 2 thread id # OUT: 1 instantiated object or undef if no thread by that tid or detached sub object { # Obtain the parameters # If there is a defined thread id (and tid is not main thread) # Obtain the associated process id # Return blessed object if we actually got a process id # Indicate we couldn't make an object my ($class,$tid) = @_; if (defined($tid) && $tid != 0) { return if $tid == 0; my $pid = _command( '_tid2pid',$tid ); return $class->_object( $tid,$pid ) if defined( $pid ); } undef; } #object #--------------------------------------------------------------------------- # IN: 1 class # IN: 2 (optional) boolean value indicating type of list desired # OUT: 1..N instantiated objects sub list { # Obtain the class # Obtain the hash with process ID's keyed to thread ID's # Initialize list of objects # For all of the threads, ordered by ID # Add instantiated object for this thread # Return the list of instantiated objects, or num of objects in scalar context my $class = shift; my %hash = _command( '_list_tid_pid', @_ ); my @object; foreach (sort {$a <=> $b} keys %hash) { push( @object,$class->_object( $_,$hash{$_} ) ); } wantarray ? @object : scalar @object; } #list #--------------------------------------------------------------------------- sub yield { sleep 0.001; } #yield #--------------------------------------------------------------------------- # IN: 1 class or instantiated object # OUT: 1..N state of the indicated thread sub is_detached { _command( '_is_detached',shift->tid ) } #is_detached #--------------------------------------------------------------------------- # IN: 1 class or instantiated object # OUT: the memory location of the internal thread structure # Note: this won't guarantee reusable address, as it's dynamically generated sub _handle { # Obtain the class or object # If is an object, return address of object # Otherwise, return address of class my $self = shift; return refaddr( $self->_object( $self->tid,$self->{'pid'} ) ) if ref($self); return refaddr( $self->_object( $self->tid,$$ ) ); } #_handle #--------------------------------------------------------------------------- # IN: 1 class or instantiated object # OUT: the thread (process) stack size sub get_stack_size { # Obtain the class or object # Return the current size my $self = shift; return _command( '_get_set_stack_size',ref($self) ? $self->tid : undef ); } #get_stack_size #--------------------------------------------------------------------------- # IN: 1 class or instantiated object # 2 new default stack size # OUT: the old default thread (process) stack size sub set_stack_size { shift; return _command( '_get_set_stack_size',undef,shift() ) } #set_stack_size #--------------------------------------------------------------------------- # IN: 1 class # IN: 2 exit status sub exit { shift; defined $_[0] ? CORE::exit($_[0]) : CORE::exit(); } #exit #--------------------------------------------------------------------------- # instance methods #--------------------------------------------------------------------------- # IN: 1 instantiated object # IN: 2 boolean value # OUT: 1..N error result (if any) of the indicated thread sub set_thread_exit_only { _command( '_set_thread_exit_only',shift->tid,shift ); } #set_thread_exit_only #--------------------------------------------------------------------------- # IN: 1 class or instantiated object # OUT: 1..N state of the indicated thread sub wantarray { # Obtain the class or object # If is an object, return thread context of specified thread # Otherwise, return thread context of current thread my $self = shift; return _command( '_wantarray',$self->tid ) if ref($self); return $THREAD_CONTEXT; } #wantarray #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1..N results of the indicated thread sub detach { # Obrain the result # Die if an error occured # Otherwise, return true my ($success, $errtxt) = _command( '_detach',shift->tid ); Carp::croak($errtxt) unless $success; return 1; } #detach #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1..N results of the indicated thread sub join { # Obrain the result # Die if an error occured # Otherwise, return joined result (returned by joined thread) in appropriate context my ($success, @result) = _command( '_join',shift->tid ); Carp::croak(@result) unless $success; return defined CORE::wantarray ? CORE::wantarray ? @result : $result[-1] : (); } #join #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1..N error result (if any) of the indicated thread sub error { _command( '_error',shift->tid ) } #error #--------------------------------------------------------------------------- # IN: 1 instantiated threads object # 2 other instantiated threads object # OUT: 1 whether they refer to the same thread sub equal { $_[0]->tid == $_[1]->tid } #equal #--------------------------------------------------------------------------- # IN: 1 instantiated threads object # 2 other instantiated threads object # OUT: 1 whether they refer to the same thread sub nequal { $_[0]->tid != $_[1]->tid } #nequal #--------------------------------------------------------------------------- # IN: 1 instantiated threads object # OUT: 1 tid of the object sub stringify { $_[0]->tid } #stringify #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 state of the indicated thread sub is_running { _command( '_is_running',shift->tid ) } #is_running #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 state of the indicated thread sub is_joinable { _command( '_is_joinable',shift->tid ) } #is_joinable #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 state of the indicated thread sub is_deadlocked { _command( '_is_deadlocked',shift->tid ) } #is_deadlocked #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 signal number or name to send # OUT: 1 thread object sub kill { # Get the object # Get the signal # Die if incorrect usage # Return immediately if no signal defined # Die unless signal is valid # Send signal # Return thread object my $self = shift; my $signal = shift; Carp::croak("Usage: \$thr->kill('SIG...')") unless blessed($self); return $self unless defined $signal; Carp::croak("Unrecognized signal name or number: $signal") unless grep(/^$signal$/, map('SIG'.$_, split(/\s+/, $Config::Config{sig_name})), split(/\s+/, $Config::Config{sig_name}), split(/\s+/, $Config::Config{sig_num})); _command( '_kill',$self->tid,$signal ); $self; } #kill #--------------------------------------------------------------------------- # exportables #--------------------------------------------------------------------------- # IN: 1 subroutine reference of sub to start execution with # 2..N any parameters to be passed # OUT: 1 instantiated object sub async (&;@) { if (defined CORE::wantarray) { if (CORE::wantarray) { my @result = new( 'threads',@_ ); } else { my $result = new( 'threads',@_ ); } } else { new( 'threads',@_ ); } } #async #--------------------------------------------------------------------------- # standard Perl features #--------------------------------------------------------------------------- # Default reaper, if using custom CHLD signal handler (prevents thread zombies) sub REAPER { # Localize system error and status variables # Toggle flag indicating that reaper was called, if user hasn't defined a CHLD handler # For just child thread processes, loop and reap # If we are main thread, exit if shared process exited and main thread running local $!; local $?; $IFNDEF_REAPER_CALLED = 1 unless forks::signals->is_sig_user_defined('CHLD'); while (my $pid = each %CHILD_PID) { my $waitpid = waitpid($pid, WNOHANG); if (defined($waitpid) && $waitpid == $pid && (WIFEXITED($?) || WIFSIGNALED($?))) { delete( $CHILD_PID{$pid} ); if ($$ == $PID_MAIN_THREAD) { CORE::exit() if $waitpid == $SHARED && !$MAIN_EXIT_WITH_ABRT; } } } } #REAPER #--------------------------------------------------------------------------- # Shared server reaper sub REAPER_SHARED_DAEMON { # Localize system error and status variables # While we have zombie processes, loop and reap # Store exit value if process was main thread and exit value not already set # Immediately exit shared server local $!; local $?; while ((my $pid = waitpid(-1, WNOHANG)) > 0) { if ($pid == $PID_MAIN_THREAD && (WIFEXITED($?) || WIFSIGNALED($?))) { $EXIT_VALUE = ($? >> 8) & 0xFF unless defined($EXIT_VALUE); $RUNNING = 0; } } } #REAPER_SHARED_DAEMON #--------------------------------------------------------------------------- # Special ABRT signal handler for main thread sub _sigtrap_handler_main_abrt { # Revert to system default CHLD handler (most portable exit behavior) # Just reutrn if ABRT already handled, or if main thread is shutting down # Mark main thread as exiting due to ABRT from shared process # Exit immediately $forks::signals::sig->{CHLD} = 'DEFAULT'; return if $MAIN_ABRT_HANDLED++ || $SHUTTING_DOWN || $SHUTTING_DOWN_END; $MAIN_EXIT_WITH_ABRT = 1; CORE::exit(); } #_sigtrap_handler_main_abrt #--------------------------------------------------------------------------- # Default sigtrap handler sub _sigtrap_handler_defined { # Obtain the signal sent # If valid signal and this is a valid thread # If not main thread and currently not exchanging with server # Add signal to deferred list unless it is already in the list # Return immediately with false (void) value # Return with true value my ($sig) = @_; if ($sig && exists($ISATHREAD{$$}) && defined($PID) && $$ == $PID) { if ($threads::SEND_IN_PROGRESS || ($threads::RECV_IN_PROGRESS && length($threads::RECV_DATA) > 0)) { push @DEFERRED_SIGNAL, $sig unless grep(/^$sig$/, @DEFERRED_SIGNAL); return; } } return 1; } sub _sigtrap_handler_undefined { # Call defined thread sig handler routine (to handle deferred signal logic, if required) # If valid signal and this is a valid thread (not main thread) # Print a general warning # Mark this thread as shutting down (for quiet exit) # Exit my ($sig) = @_; return unless _sigtrap_handler_defined(@_); if ($sig && exists($ISATHREAD{$$}) && defined($PID) && $$ == $PID && $TID) { print STDERR "Signal SIG$sig received, but no signal handler set" ." for thread $TID\n" if warnings::enabled('threads'); } $SHUTTING_DOWN = 1; CORE::exit(); } #_sigtrap_handler_undefined #--------------------------------------------------------------------------- # Shared variable server sigtrap handler sub _sigtrap_handler_shared { # Obtain the signal sent # Propegate signal to main thread my ($sig) = @_; CORE::kill($sig, $PID_MAIN_THREAD); } #_sigtrap_handler_shared #--------------------------------------------------------------------------- # Default module initializaton handler sub _init { # Return if module already initialized return if $HANDLED_INIT; _log( " ! global startup" ) if DEBUG; # Create a server that can only take one connection at a time or die now # Find out the port we're running on and save that for later usage # Make sure that the server is non-blocking if ($THREADS_UNIX) { _croak( "UNIX socket file '$THREADS_UNIX$$' in use by non-socket file" ) if -e $THREADS_UNIX.$$ && !-S $THREADS_UNIX.$$; _croak( "Unable to delete UNIX socket file '$THREADS_UNIX$$'" ) if -S $THREADS_UNIX.$$ && !unlink($THREADS_UNIX.$$); $QUERY = IO::Socket::UNIX->new( Local => $THREADS_UNIX.$$, Listen => SOMAXCONN, ) or _croak( "Couldn't start the listening server: $@" ); chmod 0777, $THREADS_UNIX.$$; $PORT = $THREADS_UNIX.$$; } else { $QUERY = IO::Socket::INET->new( LocalAddr => '127.0.0.1', Listen => SOMAXCONN, ) or _croak( "Couldn't start the listening server: $@" ); $PORT = $QUERY->sockport; } _nonblock( $QUERY ); # Perform the fork # Die if the fork really failed my $forkpid = fork; _croak( "Could not start initial fork" ) unless defined( $forkpid ); # If shared server should be child process of main thread # If we are in the parent (main thread) # Do stuff # Else (we are in the child (shared server)) # Do stuff # Else # If we are in the parent (shared server) # Do stuff # Else (we are in the child (main thread)) # Do stuff if ($THREADS_INTEGRATED_MODEL) { if ($forkpid) { $PID_MAIN_THREAD = $$; $SHARED = $forkpid; _init_main(1); } else { $PID_MAIN_THREAD = getppid(); $SHARED = $$; _server_pre_startup(); _init_server(); } } else { if ($forkpid) { $PID_MAIN_THREAD = $forkpid; $SHARED = $$; _server_pre_startup(); _init_server(1); } else { $PID_MAIN_THREAD = $$; $SHARED = getppid(); _init_main(); } } # Mark forks initialization as complete $HANDLED_INIT = 1; } #_init #--------------------------------------------------------------------------- # Default main thread initialization handler sub _init_main { my $is_parent = shift; # Use forks::signal to overload %SIG for safest forks-aware signal behavior # TODO: consider this case as a less-invasive signal handling system, for # cases where users wish to have fully overloadable signals via %SIG # foreach (@TRAPPED_SIGNAL) { # import sigtrap 'handler', (defined($SIG{$_}) # ? \&_sigtrap_handler_defined # : \&_sigtrap_handler_undefined), $_; # } # import sigtrap ('handler', \&_sigtrap_handler_main_abrt, 'ABRT'); # import sigtrap ('handler', ($FORCE_SIGCHLD_IGNORE ? 'IGNORE' : \&REAPER), 'CHLD'); import forks::signals ifndef => { %THR_UNDEFINED_SIG, ABRT => \&_sigtrap_handler_main_abrt, CHLD => $FORCE_SIGCHLD_IGNORE ? 'IGNORE' : [\&REAPER, SA_NOCLDSTOP | SA_RESTART] }, ifdef => { %THR_DEFINED_SIG, ABRT => \&_sigtrap_handler_main_abrt, CHLD => $FORCE_SIGCHLD_IGNORE ? 'IGNORE' : \&REAPER }; # Make this thread 0 _init_thread(_run_CLONE_SKIP()); } #_init_main #--------------------------------------------------------------------------- # Default thread server initializaton handler sub _init_server { my $is_parent = shift; # Reset all signal handlers to default # If is parent # Configure signal handlers # Configure child signal handler # Prevent server taking over TTY on exit when in debugger # Start handling requests as the server delete( @SIG{keys %SIG} ); if ($is_parent) { import sigtrap ('handler', \&_sigtrap_handler_shared, qw(normal-signals USR1 USR2 die error-signals)); $SIG{CHLD} = \&REAPER_SHARED_DAEMON; } $DB::inhibit_exit = 0; &_server; } #_init_server #--------------------------------------------------------------------------- # IN: 1 class (ignored) # 2..N subroutines to export (default: async only) sub import { # Obtain the class my $self = shift; # Overload string context of thread object to return TID, if requested if ((my $idx = List::MoreUtils::firstidx( sub { $_ eq 'stringify' }, @_)) >= 0) { import overload '""' => \&stringify; splice(@_, $idx, 1); } # Initialize module thread server process, if required _init(); # Set exit context of threads, if requested if ((my $idx = List::MoreUtils::firstidx( sub { $_ eq 'exit' }, @_)) >= 0) { my @args = splice(@_, $idx, 2); if ($args[1] eq EXIT_THREADS_ONLY) { _command( '_set_threads_exit_only',1 ); } elsif ($args[1] eq EXIT_THREAD_ONLY) { threads->set_thread_exit_only(1); } } # Set thread stack size, if requested if ((my $idx = List::MoreUtils::firstidx( sub { $_ eq 'stack_size' }, @_)) >= 0) { my @args = splice(@_, $idx, 2); _command( '_get_set_stack_size',undef,$ITHREADS_STACK_SIZE || $args[1] ); } # Perform the export needed _export( scalar(caller()),@_ ); } #import BEGIN { # forks::shared and threads::shared share same import method *forks::import = *forks::import = \&import; } #_BEGIN # Functions to allow external modules an API hook to specific runtime states sub _server_pre_startup {} sub _server_post_startup {} sub _end_server_pre_shutdown {} sub _end_server_post_shutdown {} #--------------------------------------------------------------------------- my $END_CALLED; sub _END { # Revert to default CHLD handler to insure portable, reliable shutdown # Prevent ths subroutine from ever being called twice # Localize $! and $? to prevent accidental override during shutdown # If this process is the shared server # Calculate and report stats on running and/or unjoined threads (excluding main thread) # Forcefully terminate any lingering thread processes (except main thread) # Forcefully terminate main thread (allowing END block to perform cleanup) # Shutdown the socket server # Delete UNIX socket file if the socket file exists # Allow external modules opportunity to clean up thread process group resources # If this process is a valid thread (including main thread if $THREADS_INTEGRATED_MODEL) # Mark this thread as shutting down # Reset CORE::GLOBAL::exit to default # Indicate that this process has been shut down to the server (if appropriate) # Mark this thread as shut down (so we won't send or receive anymore) # If this is main thread using non-daemon model # Wait a bit for shared process to exit (or hard kill if it doesn't respond) # Synchronize thread exit status with shared process (as required) # Alter exit status, if required $forks::signals::sig->{CHLD} = 'DEFAULT'; LOCALEXITBLOCK: { last if $END_CALLED; $END_CALLED = 1; local $!; local $?; if (!exists( $ISATHREAD{$$} ) && defined($SHARED) && $$ == $SHARED) { my $running_and_unjoined = 0; my $finished_and_unjoined = 0; my $running_and_detached = 0; foreach my $tid (grep(!/^0$/, keys %TID2PID)) { if ($DETACHED !~ m/\b$tid\b/) { $running_and_unjoined++ if !exists $RESULT{$tid} && exists $NOTJOINED{$tid}; $finished_and_unjoined++ if exists $RESULT{$tid}; } } foreach (grep(!/^0$/, keys %DETACHED_NOTDONE)) { $running_and_detached++; } print STDERR "Perl exited with active threads:\n" ."\t$running_and_unjoined running and unjoined\n" ."\t$finished_and_unjoined finished and unjoined\n" ."\t$running_and_detached running and detached\n" if ($running_and_unjoined || $finished_and_unjoined || $running_and_detached); my @pidtokill; while (my ($tid, $client) = each %TID2CLIENT) { eval { my $written = send( $client,'',0 ); if (defined( $written )) { push @pidtokill, $TID2PID{$tid} if $tid && defined $TID2PID{$tid} && CORE::kill(0, $TID2PID{$tid}); }; }; } CORE::kill('SIGKILL', $_) foreach @pidtokill; CORE::kill('SIGABRT', $PID_MAIN_THREAD) if !$MAIN_EXIT_NO_ABRT && CORE::kill(0, $PID_MAIN_THREAD); $QUERY->shutdown(2) if defined $QUERY; unlink($PORT) if $THREADS_UNIX && -S $PORT; _end_server_post_shutdown(); } elsif (exists( $ISATHREAD{$$} ) && defined($PID) && $$ == $PID && ($THREADS_INTEGRATED_MODEL || $TID)) { $SHUTTING_DOWN_END = 1; { no warnings 'redefine'; *CORE::GLOBAL::exit = $old_core_global_exit; } _command( '_shutdown',$TID ) if CORE::kill(0, $SHARED) && ($TID > 0 || !$MAIN_ABRT_HANDLED); $SHUTDOWN = 1; if ($THREADS_INTEGRATED_MODEL && $TID == 0) { local $!; local $SIG{ALRM} = sub { die }; alarm(3); eval { waitpid($SHARED, 0); alarm(0); }; if ($@) { CORE::kill('SIGHUP', $SHARED) if CORE::kill(0, $SHARED); #TODO: do we really need to be this agressive? } else { $EXIT_VALUE = ($? >> 8) & 0xFF if $MAIN_EXIT_WITH_ABRT; } } } } $? = $EXIT_VALUE if defined $EXIT_VALUE && !$END_CALLED; } #_END #--------------------------------------------------------------------------- sub _CHECK { # Call end block routine # Exit with non-zero value if shared server, to prevent multiple compile check reports _END(); CORE::exit(1) if (!exists( $ISATHREAD{$$} ) && defined($SHARED) && $$ == $SHARED); } #_CHECK #--------------------------------------------------------------------------- # internal subroutines server-side #--------------------------------------------------------------------------- sub _server { # Set nice value if environment variable set and if we're running as root # Mark the parent thread id as detached { my $oldfh = select(STDOUT); $| = 1; select($oldfh); } POSIX::nice( $SERVER_NICE ) if $SERVER_NICE && !$<; $DETACHED = $NEXTTID; # Create the select object in which all the connections are stored # Initialize the length of message to be received hash # Initialize the received message hash # Initialize the var to hold current time (for time calculations each loop) my $select = IO::Select->new( $QUERY ); my %toread; my %read; my $curtime; # Localize Storable variables to allow CODE refs, if using Storable >= 2.05 local $Storable::Deparse = 1 if $Storable::VERSION >= 2.05; local $Storable::Eval = 1 if $Storable::VERSION >= 2.05; # Initialize the number of polls # While we're running in the main dispatch loop # Update timedwaiting index # Get current time # Load next event timedwaiting expiration time (if any) # Wait until there is something to do or a cond_timedwaiting event has expired # Get current time # Increment number of polls # Handle any timedwaiting events that may have expired my $polls = 0; _server_post_startup(); while ($RUNNING || %DONEWITH) { if (DEBUG) { my $clients = keys %WRITE; _log( " ! $clients>>" ) if $clients; } keys %WRITE if RESET_EACH_ITER; my $write = (each %WRITE) || ''; _update_timedwaiting_idx(); $curtime = time(); my ($sleep_min) = $write ? (.001) : List::MoreUtils::minmax( @TIMEDWAITING_IDX ? $TIMEDWAITING_IDX[0]->[2] - $curtime : $MAX_POLL_SLEEP, $DEADLOCK_DETECT_TS_NEXT ? $DEADLOCK_DETECT_TS_NEXT - $curtime : $MAX_POLL_SLEEP, $BLOCKING_JOIN_CHECK_TS_NEXT ? $BLOCKING_JOIN_CHECK_TS_NEXT - $curtime : $MAX_POLL_SLEEP ); _log( " ! max sleep time = $sleep_min" ) if DEBUG; my @reading = $select->can_read( $sleep_min > 0 ? $sleep_min : 0.001 ); $curtime = time(); _log( " ! <<".@reading ) if DEBUG and @reading; $polls++; _handle_timedwaiting(); # For all of the clients that have stuff to read # If we're done with this client, ignore further input until socket closed # If this is a new client # Accept the connection # If using INET sockets # Check if client is in the allow list # Immediately close client socket if not in allow list # And reloop # Make sure the client is non-blocking foreach my $client (@reading) { next if exists( $DONEWITH{$client} ); if ($client == $QUERY) { $client = $QUERY->accept(); unless ($THREADS_UNIX) { if ($INET_IP_MASK ne '' && $client->peerhost() !~ m/$INET_IP_MASK/) { warn 'Thread server rejected connection: ' .$client->peerhost().':'.$client->peerport().' does not match allowed IP mask'."\n"; close( $client ); next; } } _nonblock( $client ); # Save refs to real client object keyed to thread id and stringified object # Make sure the reverse lookup will work # Add the client to the list of sockets that we can select on # Send the thread ID to the client and increment (now issued) thread ID # And reloop _log( " ! adding thread $NEXTTID" ) if DEBUG; $TID2CLIENT{$NEXTTID} = $client; $CLIENT2TID{$client} = $NEXTTID; $select->add( $client ); $WRITE{$client} = _pack_response( ['_set_tid',$NEXTTID++] ); next; } # Initialize the number of bytes to be read per block # If we haven't received the length of the message yet # Obtain the length, reloop if no length yet # Reduce first read to exactly match block size my $size = $BUFSIZ; unless ($toread{$client}) { next unless $toread{$client} = _length( $client ); #_log( " <$CLIENT2TID{$client} $toread{$client} length" ) if DEBUG; $size -= MSG_LENGTH_LEN; } # Initialize scalar to receive data in # If something went wrong with reading # Die (we can't have this going about now can we) # unless call would block or was interrupted by signal # Add the data to the request read for this client if anything was read my $data; unless (defined( recv($client,$data,$size,0) ) and length($data)) { _croak( "Error ".($! ? $! + 0 : '')." reading from $CLIENT2TID{$client}: ".($! ? $! : '') ) unless ($! == EWOULDBLOCK || $! == EAGAIN || $! == EINTR); } _log( " <$CLIENT2TID{$client} ".length($data)." of $toread{$client}" ) if DEBUG; $read{$client} .= $data if defined($data); } # For all of the clients for which we have read stuff # If we have read something already # If we have all we're expecting keys %read if RESET_EACH_ITER; while (my $client = each %read) { if (my $read = length( $read{$client} )) { if ($read == $toread{$client}) { _log( " =$CLIENT2TID{$client} ".CORE::join(' ',(_unpack_request( $read{$client} ) || '')) ) if DEBUG; # Create untainted version of what we got # Go handle that # Remove the number of characters to read # Elseif we got too much # Die now $read{$client} =~ m#^(.*)$#s; _handle_request( $client,$1 ); delete( $toread{$client} ); delete( $read{$client} ); } elsif ($read > $toread{$client}) { _croak( "Got $read bytes, expected only $toread{$client} from $CLIENT2TID{$client}: ".CORE::join( ' ',_unpack_request( $read{$client} ) ) ); } } } # While there is a client to which we can write # Verify that there still is data to be written (may have changed after read) # Try to write whatever there was to write # If write was successful # If number of bytes written exactly same as what was supposed to be written # Just remove everything that was supposed to be removed # Elsif we've written some but not all because of blocking # Remove what was written, still left for next time # Else (something seriously wrong) # Die now # Else (something seriously wrong) # Die now # Fetch the next client to write to while ($write) { unless (defined $WRITE{$write}) { delete( $WRITE{$write} ); $write = each %WRITE; next; } my $written = send( $TID2CLIENT{$CLIENT2TID{$write}},$WRITE{$write},0 ); _log( " >$CLIENT2TID{$write} $written of ".length($WRITE{$write}) ) if DEBUG; if (defined( $written )) { if ($written == length( $WRITE{$write} )) { delete( $WRITE{$write} ); } else { substr( $WRITE{$write},0,$written ) = ''; } } elsif ($! == EWOULDBLOCK || $! == EAGAIN || $! == EINTR) { #defer writing this time around } elsif ($! == ECONNRESET && $CLIENT2TID{$write} == 0) { #main thread exited: wait for SIGCHLD delete( $WRITE{$write} ); next; } else { _croak( "Error ".($! ? $! + 0 : '').": Could not write ".(length $WRITE{$write}) ." bytes to $CLIENT2TID{$write}: ".($! ? $! : '') ); } $write = each %WRITE; } my $error = [$select->has_exception( .1 )] if DEBUG; if (DEBUG) { _log( " #$CLIENT2TID{$_} error" ) foreach @$error; } # If asynchronous deadlock detection enabled and next event time has expired if ($DEADLOCK_DETECT && $DEADLOCK_DETECT_PERIOD && $curtime >= $DEADLOCK_DETECT_TS_NEXT) { _detect_deadlock_all(); $DEADLOCK_DETECT_TS_NEXT = $curtime + $DEADLOCK_DETECT_PERIOD; } # If deadlock resolution is enabled and there are deadlocked threads # Get only one thread from each pair of deadlocked threads # Schedule signal for each pid to terminate to resolve deadlock # Clear deadlocked thread list if ($DEADLOCK_RESOLVE && %DEADLOCKED) { my @tid_to_kill; while (my $tid = each %DEADLOCKED) { push @tid_to_kill, $tid if defined $DEADLOCKED{$DEADLOCKED{$tid}} && $tid == $DEADLOCKED{$DEADLOCKED{$tid}}; delete $DEADLOCKED{$tid}; } foreach my $tid (@tid_to_kill) { print STDERR "Deadlock resolution: Terminating thread" ." $tid (PID $TID2PID{$tid}) with signal $DEADLOCK_RESOLVE_SIG\n" if warnings::enabled(); $TOSIGNAL{$tid} = $DEADLOCK_RESOLVE_SIG; } %DEADLOCKED = (); } # For all of the clients that we need to send signals to # Make sure we won't check this client again # Skip this client if it's already terminated # Send requested signal to appropriate thread # If signal was SIGKILL, manually handle clean up # (note: this assumes any other signal would result in process safe exit) while (my ($tid, $signal) = each %TOSIGNAL) { delete( $TOSIGNAL{$tid} ); next unless defined $TID2CLIENT{$tid}; my $success = _signal_thread($tid, $signal); CORE::kill('SIGKILL', $TID2PID{$tid}) unless $success; _log( "sent $TID2PID{$tid} signal ".abs($signal) ) if DEBUG; _cleanup_unsafe_thread_exit($tid) if !$success || $signal eq 'KILL' || $signal eq 'SIGKILL' || ($signal =~ m/^\d+$/ && $signal == SIGKILL); } # If next check time has expired # For all of the clients that are currently blocking on threads # Check that process is still alive; otherwise, cleanup dead thread # If that did not clear the waiting thread # Output a warning (from server) # Notify the thread with undef (should really be an error) # Also check that main thread is still alive if ($curtime >= $BLOCKING_JOIN_CHECK_TS_NEXT) { while (my $tid = each %BLOCKING_JOIN) { unless (CORE::kill(0, $TID2PID{$tid})) { _cleanup_unsafe_thread_exit($tid); if (exists $BLOCKING_JOIN{$tid}) { warn "BLOCKING_JOIN manually cleared for tid #$tid"; $WRITE{$TID2CLIENT{$tid}} = $undef; } } } $BLOCKING_JOIN_CHECK_TS_NEXT = $curtime + $BLOCKING_JOIN_CHECK_PERIOD; $RUNNING = 0 unless CORE::kill(0, $PID_MAIN_THREAD); } # For all of the clients that we're done with # Reloop if there is still stuff to send there # Make sure we won't check this client again keys %DONEWITH if RESET_EACH_ITER; while (my $client = each %DONEWITH) { next if $RUNNING && exists( $WRITE{$client} ); _log( " !$CLIENT2TID{$client} shutting down" ) if DEBUG; delete( $DONEWITH{$client} ); # Obtain the thread id # Obtain the client object (rather than its stringification) # Remove the client from polling loop # Properly close the client from this end # If we were waiting for this client to exit # Mark that main thread should not be ABRT signalled, if main thread is shutting down # Mark server to shutdown my $tid = $CLIENT2TID{$client}; $client = $TID2CLIENT{$tid}; $select->remove( $client ); close( $client ); if ($RUNNING eq $client) { $MAIN_EXIT_NO_ABRT = 1 if $tid == 0; $RUNNING = 0; } # Do the clean up my $pid = $TID2PID{$tid}; delete( $TID2CLIENT{$tid} ); delete( $CLIENT2TID{$client} ); delete( $PID2TID{$pid} ) if defined $pid; if ($DETACHED =~ m/\b$tid\b/ or !exists( $NOTJOINED{$tid} )) { delete( $TID2PID{$tid} ); delete( $TID2STACKSIZE{$tid} ); delete( $TID2CONTEXT{$tid} ); } } } # Allow external modules opportunity to clean up thread process group resources # Exit now, we're in the shared process and we've been told to exit _log( " ! global exit: did $polls polls" ) if DEBUG; _end_server_pre_shutdown(); defined $EXIT_VALUE ? CORE::exit($EXIT_VALUE) : CORE::exit(); } #_server #--------------------------------------------------------------------------- # IN: 1 tid to cleanup # 2 (optional) error text to report sub _cleanup_unsafe_thread_exit { # Get tid of thread to cleanup # Get error text to display in stack trace my $tid = shift; my $errtxt = shift || ''; Carp::cluck( "Performing cleanup for dead thread $tid: $errtxt" ) if warnings::enabled() && $errtxt ne ''; #TODO: disable these conditions? # If thread isn't already joined and shutdown # Mark this thread as shutdown # Delete any messages that might have been pending for this client if (defined $TID2CLIENT{$tid}) { _shutdown($TID2CLIENT{$tid}, $tid); delete( $WRITE{$TID2CLIENT{$tid}} ); } } #_cleanup_unsafe_thread_exit #--------------------------------------------------------------------------- sub _update_timedwaiting_idx { # If timedwaiting index expired flag set # Translate timedwaiting hash to sorted (index) array of all events # Reset index expired flag if ($TIMEDWAITING_IDX_EXPIRED) { @TIMEDWAITING_IDX = (); if (keys %TIMEDWAITING) { push @TIMEDWAITING_IDX, map($_, sort {$a->[2] <=> $b->[2]} map(@{$TIMEDWAITING{$_}}, keys %TIMEDWAITING)); } $TIMEDWAITING_IDX_EXPIRED = 0; } } #_update_timedwaiting_idx #--------------------------------------------------------------------------- sub _handle_timedwaiting { # For all timed wait events # Obtain the tid, time, and ordinal event # If this timed event is expired and a timed event exists for this ordinal # Parse all timed events # If current event in list of timed events is the matching event to what has expired # Get the tid and target lock ordinal of the event # Delete event from list & expire timed event index # If ordinal is currently locked # Signal this variable for when the target locked variable is unlocked later # Else (ordinal not locked) # Assign lock to this tid # Immediately notify blocking thread that it should continue # Else last loop: minimize index parsing, as when current event isn't expired, remaining (ordered) events in array aren't either foreach (@TIMEDWAITING_IDX) { my (undef, $ordinal, $time, undef, $id) = @{$_}; if ($time <= time() && defined $TIMEDWAITING{$ordinal} && ref($TIMEDWAITING{$ordinal}) eq 'ARRAY' && @{$TIMEDWAITING{$ordinal}}) { my @tw_events = @{$TIMEDWAITING{$ordinal}}; for (my $i = 0; $i < scalar @tw_events; $i++) { if ($tw_events[$i]->[4] == $id) { my ($tid, $l_ordinal) = @{splice(@{$TIMEDWAITING{$ordinal}}, $i, 1)}[0,3]; delete $TIMEDWAITING{$ordinal} unless @{$TIMEDWAITING{$ordinal}}; $TIMEDWAITING_IDX_EXPIRED = 1; if (defined $LOCKED[$l_ordinal]) { push @{$TIMEDWAITING_EXPIRED[$ordinal]}, [$tid, $l_ordinal]; } else { $LOCKED[$l_ordinal] = $tid; $WRITE{$TID2CLIENT{$tid}} = $false; } last; } } } else { last; } } } #_handle_timedwaiting #--------------------------------------------------------------------------- # IN: 1 socket to put into nonblocking mode sub _nonblock { # not sure whether needed, this is really cargo-culting # Obtain the socket in question # Obtain the current flags # Set the non-blocking flag onto the current flags my $socket = shift; my $flags = fcntl( $socket, F_GETFL, 0 ) or _croak( "Error ".($! ? $! + 0 : '').": Can't get flags for socket: ".($! ? $! : '') ); fcntl( $socket, F_SETFL, $flags | O_NONBLOCK ) or _croak( "Error ".($! ? $! + 0 : '').": Can't make socket nonblocking: ".($! ? $! : '') ); } #_nonblock #--------------------------------------------------------------------------- # IN: 1 client socket # 3 flag whether to automatically detect deadlocks # 2 detection period, in seconds # 3 flag whether to resolve deadlock conflicts sub _set_deadlock_option { # Obtain client # Set deadlock detection flag and period # If period was changed # Set deadlock detection period (stored as a positive number) # Set next deadlock detection event, # Set deadlock resolution flag # If deadlock resolver is enabled, immediately do global deadlock detection # Make sure the client knows the result my $client = shift; $DEADLOCK_DETECT = shift @_ ? 1 : $DEADLOCK_DETECT; my $period = shift @_; if (defined $period) { $DEADLOCK_DETECT_PERIOD = abs($period) + 0; $DEADLOCK_DETECT_TS_NEXT = time() + $DEADLOCK_DETECT_PERIOD; } $DEADLOCK_RESOLVE = shift @_ ? 1 : $DEADLOCK_RESOLVE; my $signal = shift @_; $DEADLOCK_RESOLVE_SIG = abs($signal) if $signal; _detect_deadlock_all() if $DEADLOCK_RESOLVE; $WRITE{$client} = $true; } #_set_deadlock_option #--------------------------------------------------------------------------- # IN: 1 TID of thread waiting to lock # 2 Ordinal of variable TID is waiting to lock # OUT: 1 True or false, indicating whether or not deadlock was detected # 2 TID of thread deadlocked with input TID # 3 Ordinal of other variable involved in deadlock that is locked by output TID sub _detect_deadlock { # Obtain thread TID (1) and ordinal that it wants to lock # Verify that that the ordinal is already locked (and not by the thread to analyze) # Get TID (2) of current ordinal locker # Get ordinal that TID (2) is currently blocking on # If TID (2) is blocking on TID (1) locked variable # Warn of the deadlock # Mark thread pair as deadlocked # Return true result # Return false (no deadlock detected) my ($tid1, $tid1_locking_ordinal) = @_; if (defined $LOCKED[$tid1_locking_ordinal] && $LOCKED[$tid1_locking_ordinal] != $tid1) { my $tid2 = $LOCKED[$tid1_locking_ordinal]; my $tid2_locking_ordinal = List::MoreUtils::firstidx( sub { ref($_) eq 'ARRAY' ? grep(/^$tid2$/, @{$_}) : 0 }, @LOCKING); if ($tid2_locking_ordinal != -1 && defined $LOCKED[$tid2_locking_ordinal]) { print STDERR "Deadlock detected:\n" .sprintf("% 7s% 12s% 13s %s\n",'TID','SV LOCKED','SV LOCKING','Caller') .sprintf("% 7d% 12d% 13d %s\n", $tid1, $tid2_locking_ordinal, $tid1_locking_ordinal, CORE::join(' at line ', @{$TID2LOCKCALLER{$tid1}}[1..2])) .sprintf("% 7d% 12d% 13d %s\n", $tid2, $tid1_locking_ordinal, $tid2_locking_ordinal, CORE::join(' at line ', @{$TID2LOCKCALLER{$tid2}}[1..2])) if warnings::enabled(); $DEADLOCKED{$tid1} = $tid2; $DEADLOCKED{$tid2} = $tid1; return CORE::wantarray ? (1, $tid2, $tid2_locking_ordinal) : 1; } } return 0; } #_detect_deadlock #--------------------------------------------------------------------------- # OUT: 1 Total number of deadlock (in terms of thread pairs) detected # 2 Num of unique deadlock pairs detected sub _detect_deadlock_all { # Initialize counter # For each ordinal in @LOCKING # If any threads are waiting to lock this ordinal # Increment deadlock counter foreach deadlock (unless thread is marked deadlocked) # Return count of deadlocked pairs my $num_deadlocks = 0; for (my $ord = 0; $ord <= scalar @LOCKING; $ord++) { if (defined $LOCKING[$ord] && ref($LOCKING[$ord]) eq 'ARRAY') { foreach my $tid (@{$LOCKING[$ord]}) { $num_deadlocks += _detect_deadlock($tid, $ord) unless exists $DEADLOCKED{$tid}; } } } return $num_deadlocks; } #_detect_deadlock_all #--------------------------------------------------------------------------- # IN: 1 TID of thread to signal # 2 Signal to send (ID, name, or SIGname) sub _signal_thread { # Obtain the TID to signal # Obtail the signal to send # Determine the signal name or ID # Send the signal my $tid = shift; my $signal = shift; my $mysig = uc($signal); $mysig = $1 if $mysig =~ m/^SIG(\w+)/; my $sigidx = List::MoreUtils::firstidx( sub { $_ eq $mysig }, split(/\s+/, $Config::Config{sig_name})); my $signum = $sigidx == -1 ? $signal : (split(/\s+/, $Config::Config{sig_name}))[$sigidx]; if (CORE::kill(0, $TID2PID{$tid})) { return CORE::kill($signal, $TID2PID{$tid}); } else { return 0; } } #_signal_thread #--------------------------------------------------------------------------- # internal subroutines client-side #--------------------------------------------------------------------------- # IN: 1 namespace to export to # 2..N subroutines to export sub _export { # Obtain the namespace # If we're supposed to debug the server also # Set debug flag # Lose the parameter my $namespace = shift().'::'; if (defined( $_[0] ) and $_[0] eq 'debug') { $DEBUG = 1; shift; } # Set the defaults if nothing specified # Allow for evil stuff # Export whatever needs to be exported @_ = qw(async) unless @_; no strict 'refs'; *{$namespace.$_} = \&$_ foreach @_; } #_export #--------------------------------------------------------------------------- # IN: 1 flag: whether to mark the thread as detached sub _init_thread { # Get results of _run_CLONE_SKIP from parent # Get return context of thread # Get flag whether this thread should start detached or not # Get stack size for this thread # Mark this process as a thread # Reset thread local tid value (so the process doesn't have its parent's tid) # Reset thread local pid value (so the process doesn't have its parent's pid) # Store the return context of this thread my $clone_skip = shift; my $thread_context = shift; my $is_detached = shift; my $stack_size = shift; $ISATHREAD{$$} = undef; undef( $TID ); undef( $PID ); $THREAD_CONTEXT = $thread_context; # Attempt to create a connection to the server or die if ($THREADS_UNIX) { $QUERY = IO::Socket::UNIX->new( Peer => $PORT, ) or _croak( "Couldn't connect to query server: $@" ); } else { $QUERY = IO::Socket::INET->new( PeerAddr => '127.0.0.1', PeerPort => $PORT, ) or _croak( "Couldn't connect to query server: $@" ); } # Obtain the initial message from the query server # Die now if it is the wrong type of message # Set the tid # Set the pid # Disable debug on process exit if this isn't main thread # Send the command to register the pid (unless starting detached or is main thread) # Execute all of the CLONE subroutines if not in the base thread my @param = _receive( $QUERY ); _croak( "Received '$param[0]' unexpectedly" ) if $param[0] ne '_set_tid'; $TID = $param[1]; $PID = $$; $DB::inhibit_exit = 0 if $TID; _send( $QUERY,'_register_pid',$TID,$$,($is_detached || !$TID ? undef : getppid()),$thread_context,$is_detached,$stack_size ); _run_CLONE($clone_skip) if $TID; # Wait for result of registration, die if failed # If this is not main thread # Use forks::signal to overload %SIG for safest forks-aware signal behavior _croak( "Could not register pid $$ as tid $TID" ) unless _receive( $QUERY ); if ($TID > 0) { import forks::signals ifndef => { %THR_UNDEFINED_SIG, CHLD => $FORCE_SIGCHLD_IGNORE ? 'IGNORE' : [\&REAPER, SA_NOCLDSTOP | SA_RESTART] }, ifdef => { %THR_DEFINED_SIG, CHLD => $FORCE_SIGCHLD_IGNORE ? 'IGNORE' : \&REAPER }; } # Reinitialize random number generator (as we're simulating new interpreter creation) # Overload global exit to conform to ithreads API (exits all threads). srand; { no warnings 'redefine'; *CORE::GLOBAL::exit = sub { threads::_command( '_toexit',$_[0] ); defined $_[0] ? CORE::exit($_[0]) : CORE::exit(); }; } return 1; } #_init_thread #--------------------------------------------------------------------------- # internal subroutines, both server-side as well as client-side #--------------------------------------------------------------------------- # IN: 1 arrayref of parameters to be put in message # IN: 2 command filter type (request or response) # IN: 3 command name # OUT: 1 formatted message (MSG_LENGTH_LEN bytes packed length + CMD_TYPE_INTERNAL + data) sub _pack { my $data_aref = shift; my $cmd_fltr_type = shift; my $cmd_name = shift; my $cmd_num = $cmd_type_to_num{$cmd_name} if $cmd_name; my $is_default_pack_type = defined $cmd_fltr_type && defined $cmd_num ? 0 : 1; # If using default pack type # Freeze the parameters that have been passed # Else # Pack data using custom filter my $data; if ($is_default_pack_type) { $data = pack('C', CMD_TYPE_DEFAULT).Storable::freeze( $data_aref ); } else { my $filter = $cmd_num_to_filter[$cmd_num]->[$cmd_fltr_type]->[CMD_FLTR_ENCODE]; $data = pack('C', CMD_TYPE_INTERNAL).pack('S', $cmd_num).$filter->($data_aref); } # Calculate the length, pack it and return it with the frozen stuff pack( 'N',length( $data ) ).$data; } #_pack_internal #--------------------------------------------------------------------------- # IN: 1 arrayref of parameters to be put in message # IN: 2 command name # OUT: 1 formatted message sub _pack_request { _pack(shift, CMD_FLTR_REQ, @_); } #_pack_request #--------------------------------------------------------------------------- # IN: 1 arrayref of parameters to be put in message # IN: 2 command name # OUT: 1 formatted message sub _pack_response { _pack(shift, CMD_FLTR_RESP, @_); } #_pack_response #--------------------------------------------------------------------------- # IN: 1 formatted message (without MSG_LENGTH_LEN byte length info) # IN: 2 command filter type (request or response) # OUT: 1..N [msg name (if known), whatever was passed to "_pack"] sub _unpack { # Handle either default or custom filtered messages my $msg = shift; my $cmd_fltr_type = shift; my $type = unpack('C', substr($msg, CMD_TYPE_IDX, CMD_TYPE_LEN)); if ($type == CMD_TYPE_DEFAULT) { return (undef, @{Storable::thaw( substr($msg, CMT_TYPE_FROZEN_CONTENT_IDX) )}); } elsif ($type == CMD_TYPE_INTERNAL) { my $cmd_num = unpack('S', substr($msg, CMD_TYPE_INTERNAL_SUBNAME_IDX, CMD_TYPE_INTERNAL_SUBNAME_LEN)); my $filter = $cmd_num_to_filter[$cmd_num]->[$cmd_fltr_type]->[CMD_FLTR_DECODE]; return ($cmd_num_to_type[$cmd_num], $filter->(substr($msg, CMD_TYPE_INTERNAL_CONTENT_IDX))); } else { _croak ( "Unknown command type: $type" ); } } #_unpack #--------------------------------------------------------------------------- # IN: 1 formatted message (without MSG_LENGTH_LEN byte length info) # OUT: 1..N [msg name (if known), whatever was passed to "_pack"] sub _unpack_request { _unpack(shift, CMD_FLTR_REQ); } #_unpack_request #--------------------------------------------------------------------------- # IN: 1 formatted message (without MSG_LENGTH_LEN byte length info) # OUT: 1..N [msg name (if known), whatever was passed to "_pack"] sub _unpack_response { _unpack(shift, CMD_FLTR_RESP); } #_unpack_response #--------------------------------------------------------------------------- # IN: 1 client object # 2 flag: don't croak if there is no length yet # OUT: 1 length of message to be received sub _length { # Obtain client # Initialize length variable # While true # If we successfully read # Add length read to total # If we read successfully # If we got enough bytes for a length # Return the actual length # Elsif we didn't get anything # Return 0 if we don't need to croak yet # Break out of loop (no data found, where data was expected) # Decrease how much left there is to read by how much we just read # Elsif action would block or was interrupted by a signal # Sleep for a short time (i.e. don't hog CPU) # Else # Break out of loop (as some other error occured) my $client = shift; my $total_length = 0; my $todo = MSG_LENGTH_LEN; while ($total_length < MSG_LENGTH_LEN) { my $result = recv( $client,my $length,$todo,0 ); if (defined( $result )) { $total_length += length( $length ); if ($total_length == MSG_LENGTH_LEN) { return unpack( 'N',$length ); } elsif ($total_length == 0) { return 0 if shift; last; } $todo -= length( $length ); } elsif ($! == EWOULDBLOCK || $! == EAGAIN || $! == EINTR) { sleep 0.001; } else { last; } } # If was ECONNABORTED (server abort) or ECONNRESET (client abort) # If is a thread # Warn and exit immediately (server connection terminated, # likely due to main thread shutdown) # Else (is shared server) # Clear the error if this was main thread exiting # Cleanup "dead" thread # Report no data (length 0) # Unless we're shutting down and we're not running in debug mode # Die, there was an error my $tid = defined $TID ? 'server' : $CLIENT2TID{$client}; my $errtxt = "Error ".($! ? $! + 0 : '') .": Could not read length of message" .(defined $tid ? " from $tid" : '').": ".($! ? $! : '') if $!; if (!$! || $! == ECONNABORTED || $! == ECONNRESET) { if (exists( $ISATHREAD{$$} )) { $SHUTTING_DOWN = 1; _log( "Thread $TID terminated abnormally: $errtxt" ) if DEBUG; #warn "***_length: Thread $TID terminated abnormally: $errtxt"; #TODO: for debugging only CORE::exit(); } else { $errtxt = undef if $CLIENT2TID{$client} == 0; _cleanup_unsafe_thread_exit($CLIENT2TID{$client}, $errtxt); return 0; } } _croak( $errtxt ) unless (($SHUTTING_DOWN || $SHUTTING_DOWN_END) && !DEBUG); } #_length #--------------------------------------------------------------------------- # IN: 1 client object # 2 frozen message to send sub _send { # Obtain the client object # Create frozen version of the data # Calculate the length of data to be sent my $client = shift; my $frozen = grep(/^$_[0]$/, @cmd_filtered) ? _pack_request( \@_, shift ) : _pack_request( \@_, $_[0] ); my $length = length( $frozen ); _log( "> ".CORE::join(' ',map {$_ || ''} eval {_unpack_request( substr($frozen,MSG_LENGTH_LEN) )}) ) if DEBUG; # Localize and set thread data comm flag # Loop while there is data to send # Send the data, find out how many really got sent # If data was sent # Remove sent data from string buffer # Increment total bytes sent # Elsif action would block or was interrupted by a signal # Sleep for a short time (i.e. don't hog CPU) # Else (an error occured) # If was ECONNABORTED (server abort) or ECONNRESET (client abort) # Warn and exit immediately (server connection terminated, likely due to main thread shutdown) # Die now unless shuttind down and not in debug mode # Return immediately $frozen =~ m#^(.*)$#s; my ($data, $total_sent) = ($1, 0); DEFERREDSIGBLOCK: { local $threads::SEND_IN_PROGRESS = 1; while ($total_sent < $length) { my $sent = send( $client,$data,0 ); if (defined( $sent )) { substr($data, 0, $sent) = ''; $total_sent += $sent; } elsif ($! == EWOULDBLOCK || $! == EAGAIN || $! == EINTR) { sleep 0.001; } else { my $errtxt = "Error ".($! ? $! + 0 : '') ." when sending message to server: ".($! ? $! : ''); if (!$! || $! == ECONNABORTED || $! == ECONNRESET) { warn "Thread $TID terminated abnormally: $errtxt" if warnings::enabled() && $TID && !$SHUTTING_DOWN && !$SHUTTING_DOWN_END; $SHUTTING_DOWN = 1; #warn "===Thread $TID terminated abnormally: $errtxt"; #TODO: for debugging only CORE::exit(); } _croak( $errtxt ) unless (($SHUTTING_DOWN || $SHUTTING_DOWN_END) && !DEBUG); return; } } } # Handle deferred signals # Reset deferred signal list $SIG{$_}->($_) foreach (@DEFERRED_SIGNAL); @DEFERRED_SIGNAL = (); } #_send #--------------------------------------------------------------------------- # IN: 1 client object # OUT: 1..N parameters of message sub _receive { # Obtain the client object # Localize and set thread comm flag # Block signals, if using custom CHLD signal handler # Obtain the length # Initialize the data to be received my $client = shift; DEFERREDSIGBLOCK: { local $threads::RECV_IN_PROGRESS = 1; my $length = my $todo = _length( $client ); my $frozen; # While there is data to get # Get some data # If we got data # Add what we got this time # If we got it all # Untaint what we got # Obtain any parameters if possible # Remove method type from parameters # Return the result # Set up for next attempt to fetch # ElseIf call would block or was interrupted by signal # Sleep a bit (to not take all CPU time) while ($todo > 0) { local $threads::RECV_DATA = ''; my $result = recv( $client,$threads::RECV_DATA,$todo,0 ); if (defined $result) { $frozen .= $threads::RECV_DATA; if (length( $frozen ) == $length) { $frozen =~ m#^(.*)$#s; my @result = _unpack_response( $1 ); shift @result; _log( "< @{[map {$_ || ''} @result]}" ) if DEBUG; return CORE::wantarray ? @result : $result[0]; } $todo -= length( $threads::RECV_DATA ); } elsif ($! == EWOULDBLOCK || $! == EAGAIN || $! == EINTR) { sleep 0.001; } else { last; } } } # Handle deferred signals # Reset deferred signal list $SIG{$_}->($_) foreach (@DEFERRED_SIGNAL); @DEFERRED_SIGNAL = (); # Unless we're shutting down and we're not running in debug mode # Die now (we didn't get the data) unless (($SHUTTING_DOWN || $SHUTTING_DOWN_END) && !DEBUG) { _croak( "Error ".($! ? $! + 0 : '').": Did not receive all bytes from $CLIENT2TID{$client}: ".($! ? $! : '') ); } } #_receive #--------------------------------------------------------------------------- # all client-side handler internal subroutines from here on #--------------------------------------------------------------------------- # IN: 1 command to execute # 2..N parameters to send # OUT: 1 values returned by server sub _command { # Return now if this thread has shut down already or if server already shutdown # Send the command + parameters # Return immediately if main thread is shutting down in non-daemon mode # Return the result return if (defined($PID) && $$ != $PID) || $SHUTDOWN || (($SHUTTING_DOWN || $SHUTTING_DOWN_END) && !$QUERY); _send( $QUERY,@_ ); return if $$ == $PID_MAIN_THREAD && $SHUTTING_DOWN_END && $THREADS_INTEGRATED_MODEL; _receive( $QUERY ); } #_command #--------------------------------------------------------------------------- # IN: 1 class # 2 thread id # 3 process id # OUT: 1 instantiated thread object sub _object { bless {tid => $_[1], pid => $_[2]},ref($_[0]) || $_[0] } #_object #--------------------------------------------------------------------------- # all server-side handler internal subroutines from here on #--------------------------------------------------------------------------- # IN: 1 instantiated socket # 2 frozen data to be handled sub _handle_request { # Obtain the socket # Get the command name and its parameters # If this is CMD_TYPE_DEFAULT command, get sub from parameters # Allow for variable references (sub name is not a ref) # Execute the command, be sure to pass the socket my $client = shift; my ($sub,@param) = _unpack_request( shift ); $sub = shift @param unless defined $sub; no strict 'refs'; &{$sub}( $client,@param ); } #_handle_request #--------------------------------------------------------------------------- # IN: 1 client socket # 2 tid to register # 3 pid to associate with the tid # 4 flag: whether to mark thread as detached # OUT: 1 whether successful (sent to client) sub _register_pid { # Obtain the parameters # Initialize the status as error # If we received a process id # If there is a client object for this thread # If this is the first time this thread is being registered # Register this thread # Make sure we can do a reverse lookup as well # Push tid on ppid2tid queue, if thread has a parent (e.g. not main thread) # If thread is marked as detached # Add to the list of detached threads # Store return context of thread # Else # Mark thread as joinable # Store the return context of the thread # Set status to indicate success my ($client,$tid,$pid,$ppid,$thread_context,$detach,$stack_size) = @_; my $status = 0; if ($pid) { if (defined $TID2CLIENT{$tid}) { unless (exists $PID2TID{$pid}) { $TID2PID{$tid} = $pid; $PID2TID{$pid} = $tid; $TID2STACKSIZE{$tid} = defined $stack_size ? $stack_size : $ITHREADS_STACK_SIZE; push @{$PPID2CTID_QUEUE{$ppid}}, $tid if $ppid; if ($detach) { $DETACHED .= ",$tid"; $DETACHED_NOTDONE{$tid} = undef; } else { $NOTJOINED{$tid} = undef; $TID2CONTEXT{$tid} = $thread_context; } $status = 1; } } # If thread has a parent and there is a thread waiting for this ppid/ctid pair # Let that thread know # And forget that it was waiting for it if (defined $ppid && exists $BLOCKING_PPID2CTID_QUEUE{$ppid}) { _ppid2ctid_shift( $BLOCKING_PPID2CTID_QUEUE{$ppid},$ppid ); delete( $BLOCKING_PPID2CTID_QUEUE{$ppid} ); } } # Let the client know how it went $WRITE{$client} = _pack_response( [$status] ); } #_register_pid #--------------------------------------------------------------------------- # IN: 1 client socket # 2 thread id to find associated process id of # OUT: 1 associated process id sub _tid2pid { $WRITE{$_[0]} = _pack_response( [$TID2PID{$_[1]}] ) } #_tid2pid #--------------------------------------------------------------------------- # IN: 1 client socket # 2 process id to find associated thread id of # OUT: 1 associated thread id sub _pid2tid { $WRITE{$_[0]} = _pack_response( [$PID2TID{$_[1]}] ) } #_pid2tid #--------------------------------------------------------------------------- # IN: 1 client socket # 2 process id of thread calling this method # OUT: 1 associated thread id sub _ppid2ctid_shift { $WRITE{$_[0]} = _pack_response( [shift @{$PPID2CTID_QUEUE{$_[1]}}] ); } #_ppid2ctid_shift #--------------------------------------------------------------------------- # IN: 1 client socket # IN: 2 (optional) boolean value indicating type of list desired # OUT: 1..N tid/pid pairs of all threads sub _list_tid_pid { # Obtain the socket # Initialize the parameters to be sent # For all of the registered threads # Obtain the thread id # If user specified an argument to list() # If argument was a "true" value # (running) Reloop if it is detached or joined or no longer running (non-detached) # or a thread is already blocking to join it # Else # (joinable) Reloop if it is detached or joined or still running (non-detached) # Else # (all) Reloop if it is detached or joined or a thread is already blocking to join it # Add this tid and pid to the list # Store the response my $client = shift; my @param; while (my($tid,$pid) = each %TID2PID) { if (@_) { if ($_[0]) { next if $DETACHED =~ m/\b$tid\b/ or !exists( $NOTJOINED{$tid} ) or exists( $RESULT{$tid} ) or exists( $BLOCKING_JOIN{$tid} ); } else { next if $DETACHED =~ m/\b$tid\b/ or !exists( $NOTJOINED{$tid} ) or !exists( $RESULT{$tid} ); } } else { next if $DETACHED =~ m/\b$tid\b/ or !exists( $NOTJOINED{$tid} ) or exists( $BLOCKING_JOIN{$tid} ); } push( @param,$tid,$pid ); } $WRITE{$client} = _pack_response( [@param] ); } #_list_tid_pid #--------------------------------------------------------------------------- # IN: 1 client socket # 2 client process exit value # OUT: 1 thread exit status sub _toexit { # Obtain the client object # Unless thread exit should be localized to thread, main thread exited, # or another thread performed global exit (waiting for it to shutdown) # Store exit value # Mark server process as ready to exit when this thread exits # Make sure the client continues my $client = shift; my $exit_value = shift; unless ($CLIENT2TID{$client} == 0 || defined ( $EXIT_VALUE ) || $THREADS_EXIT || exists( $THREAD_EXIT{$CLIENT2TID{$client}} )) { $EXIT_VALUE = $exit_value; $RUNNING = $client; } $WRITE{$client} = $true; } #_toexit #--------------------------------------------------------------------------- # IN: 1 client socket # 2 thread id to which rule will apply # 3 boolean state rule # OUT: 1 thread exit status sub _set_thread_exit_only { # Obtain the client object # Set the appropriate client thread exit method # Make sure the client continues my $client = shift; my $tid = shift; my $thread_exit_only = shift @_ ? 1 : 0; if ($thread_exit_only) { $THREAD_EXIT{$tid} = undef; } else { delete( $THREAD_EXIT{$tid} ); } $WRITE{$client} = $true; } #_set_thread_exit_only #--------------------------------------------------------------------------- # IN: 1 client socket # 2 thread id calling this method # OUT: 1 thread exit status sub _set_threads_exit_only { # Obtain the client object # Set the global thread exit override state # Make sure the client continues my $client = shift; $THREADS_EXIT = $_[0] ? 1 : 0; $WRITE{$client} = $true; } #_set_threads_exit_only #--------------------------------------------------------------------------- # IN: 1 client socket # 2..N result of thread # OUT: 1 whether saving successful sub _tojoin { # Obtain the client object # Obrain the client error (if any) # Store the client error if there was an error # If there is a thread id for this client, obtaining it on the fly # If there is a thread waiting for this result, obtaining client on the fly # Join the thread with this result # Elseif the thread was not detached # Save the result for later fetching # Elseif the thread was detached # Mark this detached thread as done # Make sure the client knows the result my $client = shift; my $error = shift; $ERROR{$CLIENT2TID{$client}} = $error if defined $error; if (my $tid = $CLIENT2TID{$client}) { if (exists $BLOCKING_JOIN{$tid}) { #warn "case 1: the result I got was ".scalar(@_).": ".CORE::join(',', @_); #TODO: for debugging only _isjoined( $BLOCKING_JOIN{$tid},$tid,@_ ); } elsif ($DETACHED !~ m/\b$tid\b/) { $RESULT{$tid} = \@_; } elsif ($DETACHED =~ m/\b$tid\b/) { delete( $DETACHED_NOTDONE{$tid} ); } } $WRITE{$client} = $true; } #_tojoin #--------------------------------------------------------------------------- # IN: 1 client socket # 2 thread id of thread to detach # OUT: 1 whether first time detached sub _detach { # Obtain the parameters # Set flag whether first time detached # If another thread is already waiting to join this thread # Don't allow thread to become deached (return local thread exception) # Else # Detach this thread # If target thread is still running # Mark it as detached and running # Else # Cleanup internal states (results) related to thread exit # Let the client know the result my ($client,$tid) = @_; my $can_detach = $DETACHED !~ m/\b$tid\b/; my $errtxt = $can_detach ? '' : 'Thread already detached'; if (exists $BLOCKING_JOIN{$tid} || ($can_detach && !exists( $NOTJOINED{$tid} ))) { $can_detach = 0; $errtxt = 'Cannot detach a joined thread'; #warn "Thread $CLIENT2TID{$client} attempted to detach a thread ($tid) pending join by another thread ($CLIENT2TID{$BLOCKING_JOIN{$tid}})"; #TODO: debugging } if ($can_detach) { $DETACHED .= ",$tid"; if (defined $NOTJOINED{$tid}) { $DETACHED_NOTDONE{$tid} = undef; } else { delete( $RESULT{$tid} ); } delete( $TID2CONTEXT{$tid} ); delete( $TID2STACKSIZE{$tid} ); } $WRITE{$client} = _pack_response( [$can_detach, $errtxt] ); } #_detach #--------------------------------------------------------------------------- # IN: 1 client socket # 2 process id to find associated thread id of sub _waitppid2ctid { # If there is already a thread id for this process id, set that # Start waiting for the tid to arrive return &_ppid2ctid_shift if defined $PPID2CTID_QUEUE{$_[1]} && @{$PPID2CTID_QUEUE{$_[1]}}; $BLOCKING_PPID2CTID_QUEUE{$_[1]} = $_[0]; } #_waitppid2ctid #--------------------------------------------------------------------------- # IN: 1 client socket # 2 thread id of thread to wait for result of sub _join { # If the thread is detached # Propagate error to thread # ElseIf there is already a result for this thread # Mark the thread as joined and use the pre-saved result # Elseif the results were fetched before # Propagate error to thread # Elseif the thread terminated without join (i.e. terminated abnormally) # Return undef to thread # Elseif thread process not running (i.e. thread death w/ no _shutdown) # Return undef to thread # Elseif someone is already waiting to join this thread # Propagate error to thread # Elseif thread is attempting to join on itself # Propagate error to thread # Else # Start waiting for the result to arrive my ($client,$tid) = @_; if ($DETACHED =~ m/\b$tid\b/) { #warn "Thread $CLIENT2TID{$client} attempted to join a detached thread: $tid"; #TODO: for debugging only $WRITE{$client} = _pack_response( [0, 'Cannot join a detached thread'] ); } elsif (exists $RESULT{$tid}) { #warn "case 2: $CLIENT2TID{$client} joining $tid immediately"; #TODO: for debugging only _isjoined( $client,$tid,@{$RESULT{$tid}} ); } elsif (!exists( $NOTJOINED{$tid} )) { #warn "Thread $CLIENT2TID{$client} attempted to join an already joined thread: $tid"; #TODO: for debugging only $WRITE{$client} = _pack_response( [0, 'Thread already joined'] ); } elsif (!exists $TID2CLIENT{$tid}) { #warn "case 4: $CLIENT2TID{$client} cannot join $tid"; #TODO: for debugging only $WRITE{$client} = _pack_response( [0, 'Cannot join a detached or already joined thread'] ); } elsif (!exists( $TID2PID{$tid} ) || !CORE::kill(0, $TID2PID{$tid})) { #warn "case 5: $CLIENT2TID{$client} cannot join $tid"; #TODO: for debugging only $WRITE{$client} = _pack_response( [0, 'Cannot join a detached or already joined thread'] ); } elsif (defined $BLOCKING_JOIN{$tid}) { #warn "Thread $CLIENT2TID{$client} attempted to join a thread already pending join: $tid"; #TODO: for debugging only $WRITE{$client} = _pack_response( [0, 'Thread already joined'] ); } elsif ($CLIENT2TID{$client} == $tid) { $WRITE{$client} = _pack_response( [0, 'Cannot join self'] ); } else { #warn "case 6: $CLIENT2TID{$client} blocking on $tid"; #TODO: for debugging only $BLOCKING_JOIN{$tid} = $client; } } #_join #--------------------------------------------------------------------------- # IN: 1 client socket # 2 thread id of thread to return result of sub _error { # Obtain the waiting client and the tid of which to check error status # Write the current error state response my ($client,$tid) = @_; $WRITE{$client} = exists $ERROR{$tid} ? _pack_response( [$ERROR{$tid}] ) : $undef; } #error #--------------------------------------------------------------------------- # IN: 1 client socket # 2 thread id of thread, or not defined (if we want global stack size) # 3 new default stack size (defined if this is a set operation) sub _get_set_stack_size { # Obtain client socket and TID # Look up old stack size for this thread # Set new stack size, if defined and is a valid integer # Return old stack size my ($client,$tid,$size) = @_; my $old = defined $tid && exists $TID2STACKSIZE{$tid} ? $TID2STACKSIZE{$tid} : $ITHREADS_STACK_SIZE; $ITHREADS_STACK_SIZE = $size if defined $size && $size =~ m/^\d+$/o; $WRITE{$client} = _pack_response( [$old] ); } #_get_set_stack_size #--------------------------------------------------------------------------- # IN: 1 client socket # 2 thread id of thread to check state sub _is_detached { # Obtain client socket and TID # Return boolean value to thread whether deatched or not my ($client,$tid) = @_; $WRITE{$client} = $DETACHED =~ m/\b$tid\b/ ? $true : $false; } #_is_detached #--------------------------------------------------------------------------- # IN: 1 client socket # 2 thread id of thread to check state sub _is_running { # Obtain client socket and TID # Return boolean value to thread whether running or not my ($client,$tid) = @_; $WRITE{$client} = ($DETACHED =~ m/\b$tid\b/ && exists $DETACHED_NOTDONE{$tid}) || (defined $TID2PID{$tid} && !exists $RESULT{$tid} && exists $NOTJOINED{$tid}) ? $true : $false; } #_is_running #--------------------------------------------------------------------------- # IN: 1 client socket # 2 thread id of thread to check state sub _is_joinable { # Obtain client socket and TID # Return boolean value to thread whether joinable or not my ($client,$tid) = @_; $WRITE{$client} = exists $RESULT{$tid} ? $true : $false; } #_is_joinable #--------------------------------------------------------------------------- # IN: 1 client socket # 2 thread id of thread to check state sub _is_deadlocked { # Obtain client socket and TID # Obtain ordinal of shared that TID is currently trying to lock (if any) # If TID is not trying to lock anything # Return false to client # Else # Check if thread is deadlocked and write appropriate value to client # Return boolean value to thread whether deadlocked or not my ($client,$tid) = @_; my $ordinal = List::MoreUtils::firstidx( sub { ref($_) eq 'ARRAY' ? grep(/^$tid$/, @{$_}) : 0 }, @LOCKING); if ($ordinal == -1) { $WRITE{$client} = $false; } else { $WRITE{$client} = _detect_deadlock($tid, $ordinal) ? $true : $false; } } #_is_deadlocked #--------------------------------------------------------------------------- # IN: 1 client socket # 2 thread id of thread to signal # 3 (optional) signal to send sub _kill { # Obtain client socket, TID, and signal # Mark the thread to be signaled with the specified signal # Make sure the client continues my ($client,$tid,$signal) = @_; $TOSIGNAL{$tid} = $signal; $WRITE{$client} = $true; } #_kill #--------------------------------------------------------------------------- # IN: 1 client socket # 2 thread id of thread to check state sub _wantarray { # Obtain client socket and TID # Return thread context (true, defined, or undef) my ($client,$tid) = @_; $WRITE{$client} = defined $TID2CONTEXT{$tid} ? $TID2CONTEXT{$tid} ? $true : $defined : $undef; } #_wantarray #--------------------------------------------------------------------------- # IN: 1 client socket # 2 reference to hash with parameters # 3..N any extra values specified # OUT: 1 tied ordinal number sub _tie { # Obtain client socket # Obtain local copy of remote object # Create the name of the routine to fake tying with here, in shared "thread" my $client = shift; my $remote = shift; my $tiewith = 'TIE'.uc($remote->{'type'}); # Obtain the module we should tie with # If we could load that module successfully # Evaluate any code that needs to be evaluated # If there are module(s) to be used # If there is more than one # Use all of them # Else # Just use this one my $module = $remote->{'module'}; if (eval "use $module; 1") { eval $remote->{'eval'} if defined( $remote->{'eval'} ); if (my $use = $remote->{'use'} || '') { if (ref($use)) { eval "use $_" foreach @$use; } else { eval "use $use"; } } # Obtain the ordinal number to be used for this shared variable # If successful in tieing it and save the object for this shared variable # Return the ordinal (we need that remotely to link with right one here) # Return indicating error my $ordinal = $NEXTTIED++; if ($TIED[$ordinal] = $module->$tiewith( @_ )) { $WRITE{$client} = _pack_response( [$ordinal] ); return; } } $WRITE{$client} = $undef; } #_tie #--------------------------------------------------------------------------- # IN: 1 client socket # 2 ordinal number of variable # 3 fully qualified name of subroutine to execute # 4..N parameters to be passed # OUT: 1..N parameters to be returned sub _tied { # Obtain the client socket # Obtain the object to work with # Obtain subroutine name to execute my $client = shift; my $object = $TIED[shift]; my $sub = shift; # Initialize code reference # If there is a code reference already (fetch it on the fly) # Elseif this is the first time we try this subroutine # Create a non-fully qualified version of the subroutine # Attempt to get a code reference for that and save it # Call the subroutine if there is one and return the result my $code; if (exists $DISPATCH{$sub} && ($code = $DISPATCH{$sub})) { } elsif( !exists( $DISPATCH{$sub} ) ) { $sub =~ m#^(?:.*)::(.*?)$#; $code = $DISPATCH{$sub} = $object->can( $1 ); } my @result; if ($code) { foreach ($code->( $object,@_ )) { if (my $ref = reftype($_)) { my $tied = $ref eq 'SCALAR' ? tied ${$_} : $ref eq 'ARRAY' ? tied @{$_} : $ref eq 'HASH' ? tied %{$_} : $ref eq 'GLOB' ? tied *{$_} : undef; if (defined $tied && blessed($tied) eq 'threads::shared') { my $ref_obj = $TIED[$tied->{'ordinal'}]; bless($_, blessed(${$ref_obj})) if blessed(${$ref_obj}); } } push @result, $_; } } $WRITE{$client} = $code ? _pack_response( \@result ) : $undef; } #_tied #--------------------------------------------------------------------------- # IN: 1 client socket # 2 ordinal number of variable to bless # 3 class type with which bless object # OUT: 1 whether successful sub _bless { # Obtain the socket # Obtain the ordinal number of the variable # Set the tied object's blessed property my $client = shift; my $ordinal = shift; my $class = shift; bless(${$TIED[$ordinal]}, $class); # Indicate that we're done to the client $WRITE{$client} = $true; } #_bless #--------------------------------------------------------------------------- # IN: 1 client socket # 2 ordinal number of variable to analyze # OUT: 1 refaddr of variables sub _id { # Obtain the socket # Obtain the object to work with my $client = shift; my $object = $TIED[shift]; # Write response to client $WRITE{$client} = _pack_response( [refaddr( ${$object} )] ); } #_id #--------------------------------------------------------------------------- # IN: 1 client sockets # 2 ordinal number of variable to remove # OUT: 1 whether successful sub _untie { # Obtain the socket # Obtain the ordinal number of the variable # Obtain the object # If we can destroy the object, obtaining code ref on the fly # Perform whatever needs to be done to destroy my $client = shift; my $ordinal = shift; my $object = $TIED[$ordinal]; if (my $code = $object->can( 'DESTROY' )) { $code->( $object ); } # Kill all references to the variable # Indicate that we're done to the client undef( $TIED[$ordinal] ); $WRITE{$client} = $true; } #_untie #--------------------------------------------------------------------------- # IN: 1 client socket # 2 ordinal number of variable to lock sub _lock { # Obtain the client socket # Obtain the thread id of the thread # Obtain the ordinal number of the shared variable # Obtain the client caller filename and line my $client = shift; my $tid = $CLIENT2TID{$client}; my $ordinal = shift; my $line = shift; my $filename = shift; # If this shared variable is already locked, obtaining its tid on the fly # If it's the same thread id # Indicate a recursive lock for this variable # Let the client continue # Else # Add the thread to the list of ones that want to lock (and let it block) # Perform deadlock deadlock detection immediately, if appropriate if (defined $LOCKED[$ordinal]) { if ($tid == $LOCKED[$ordinal]) { $RECURSED[$ordinal]++; $WRITE{$client} = $undef; } else { push( @{$LOCKING[$ordinal]},$tid ); $TID2LOCKCALLER{$tid} = [$ordinal, $filename, $line]; _detect_deadlock($tid, $ordinal) if $DEADLOCK_DETECT && !$DEADLOCK_DETECT_PERIOD; } # Else (this variable was not locked yet) # Lock this variable # Let the client continue } else { $LOCKED[$ordinal] = $tid; $TID2LOCKCALLER{$tid} = [$ordinal, $filename, $line]; $WRITE{$client} = $undef; } } #_lock #--------------------------------------------------------------------------- # IN: 1 client socket # 2 ordinal number of variable to unlock sub _unlock { # Obtain the client socket # Obtain ordinal while checking whether locked # Do the actual unlock # Make sure the client continues my $client = shift; my $ordinal = _islocked( $client,shift ); _unlock_ordinal( $ordinal ) if $ordinal; $WRITE{$client} = $true; } #_unlock #--------------------------------------------------------------------------- # IN: 1 client socket # 2 ordinal number of (signal) variable to start waiting for # 3 (optional) ordinal number of lock variable sub _wait { # If this is second form of cond_wait # Store ordinal of signal variable # Check if the lock variable is locked and return ordinal number and thread id # Else # Check if the variable is locked and return ordinal number and thread id # Lock ordinal and ordinal are the same in this case; assign ordinal value to lock ordinal # Unlock the variable # Add this thread to the list of threads in cond_wait on this variable my ($ordinal,$tid,$l_ordinal); if (scalar @_ > 2) { $ordinal = $_[1]; ($l_ordinal,$tid) = _islocked( @_[0,2],'cond_wait' ); } else { ($ordinal,$tid) = _islocked( @_,'cond_wait' ); $l_ordinal = $ordinal; } _unlock_ordinal( $l_ordinal ); push( @{$WAITING[$ordinal]},[$tid, $l_ordinal] ); } #_wait #--------------------------------------------------------------------------- # IN: 1 client socket # 2 ordinal number of variable to start timed waiting for # 3 absolute expiration time (epoch seconds) of timedwait event # 4 (optional) ordinal number of lock variable sub _timedwait { # If this is second form of cond_wait # Store ordinal of signal variable # Check if the lock variable is locked and return ordinal number and thread id # Else # Check if the variable is locked and return ordinal number and thread id # Lock ordinal and ordinal are the same in this case; assign ordinal value to lock ordinal # Unlock the variable # Add this thread to the list of threads in cond_timedwait on this variable my ($ordinal,$tid,$l_ordinal); my $time = splice(@_, 2, 1); if (scalar @_ > 2) { $ordinal = $_[1]; ($l_ordinal,$tid) = _islocked( @_[0,2],'cond_timedwait' ); } else { ($ordinal,$tid) = _islocked( @_,'cond_timedwait' ); $l_ordinal = $ordinal; } _unlock_ordinal( $l_ordinal ); push( @{$TIMEDWAITING{$ordinal}},[$tid, $ordinal, $time, $l_ordinal, ++$TIMEDWAITING_ID] ); $TIMEDWAITING_IDX_EXPIRED = 1; } #_timedwait #--------------------------------------------------------------------------- # IN: 1 client socket # 2 ordinal number of variable to signal one sub _signal { # Obtain local copy of the client # Obtain ordinal my $client = shift; my $ordinal = shift; # Get random number to determine which lock waiting list to use first # Obtain the thread id, target lock ordinal from randomly chosen list # Obtain the information from alternate list if there is no thread id yet my $rand = rand; my ($tid, $l_ordinal) = $rand > 0.5 ? _signal_timedwaiting($ordinal) : _signal_waiting($ordinal); ($tid, $l_ordinal) = $rand > 0.5 ? _signal_waiting($ordinal) : _signal_timedwaiting($ordinal) unless defined $tid; # If a tid was found to be waiting # If the signal ordinal is the same as the lock ordinal or the variable they are waiting to relock is currently locked # Add the next thread id from the list of waiting or timed waiting threads (if any) to the head of the locking list # Else (lock var is not same as signal var and lock var is currently unlocked) # Assign lock to this tid # Immediately notify blocking thread that it should continue if (defined $tid) { if ($ordinal == $l_ordinal || defined $LOCKED[$l_ordinal]) { unshift( @{$LOCKING[$l_ordinal]}, $tid ); } else { $LOCKED[$l_ordinal] = $tid; $WRITE{$TID2CLIENT{$tid}} = $true; } } # Make sure the client continues $WRITE{$client} = $undef; } #_signal #--------------------------------------------------------------------------- # IN: 1 ordinal number of variable to signal one # OUT: 1 tid to signal # 2 ordinal for thread to lock sub _signal_waiting { # Initialize the thread id and target lock ordinal # If there exists a waiting event for this ordinal # Get the next thread id from the list of waiting threads (if any) my ($tid, $l_ordinal); if (defined $WAITING[$_[0]] && ref($WAITING[$_[0]]) eq 'ARRAY' && @{$WAITING[$_[0]]}) { ($tid, $l_ordinal) = @{shift(@{$WAITING[$_[0]]})}; } return ($tid, $l_ordinal); } #--------------------------------------------------------------------------- # IN: 1 ordinal number of variable to signal one # OUT: 1 tid to signal # 2 ordinal for thread to lock sub _signal_timedwaiting { # Initialize the thread id and target lock ordinal # If there exists a timedwaiting event for this ordinal # Assign lock to this tid my ($tid, $l_ordinal); if (defined $TIMEDWAITING{$_[0]} && ref($TIMEDWAITING{$_[0]}) eq 'ARRAY' && @{$TIMEDWAITING{$_[0]}}) { ($tid, $l_ordinal) = @{shift(@{$TIMEDWAITING{$_[0]}})}[0,3]; delete $TIMEDWAITING{$_[0]} unless @{$TIMEDWAITING{$_[0]}}; $TIMEDWAITING_IDX_EXPIRED = 1; } return ($tid, $l_ordinal); } #--------------------------------------------------------------------------- # IN: 1 client socket # 2 ordinal number of variable to signal all sub _broadcast { # Obtain local copy of the client # Obtain ordinal # If there are threads waiting or timed waiting # For all waiting or timed waiting threads # If the signal ordinal is the same as the lock ordinal or the variable they are waiting to relock is currently locked # Add it to the head of the locking list # Purge waiting list for this ordinal (as it's been transferred to locking list) # (Perl < 5.8 delete appears to sometimes corrupt array, so use undef in these cases) # Else (lock var is not same as signal var and lock var is currently unlocked) # Assign lock to this tid # Immediately notify blocking thread that it should continue # Make sure the client continues my $client = shift; my $ordinal = shift; my ($tid, $l_ordinal); if (defined $WAITING[$ordinal] && ref($WAITING[$ordinal]) eq 'ARRAY' && @{$WAITING[$ordinal]}) { foreach (@{$WAITING[$ordinal]}) { ($tid, $l_ordinal) = @{$_}; if ($ordinal == $l_ordinal || defined $LOCKED[$l_ordinal]) { unshift( @{$LOCKING[$l_ordinal]}, $tid ); } else { $LOCKED[$l_ordinal] = $tid; $WRITE{$TID2CLIENT{$tid}} = $true; } } if ($] < 5.008) { $WAITING[$ordinal] = undef; } else { delete $WAITING[$ordinal]; } } if (defined $TIMEDWAITING{$ordinal} && ref($TIMEDWAITING{$ordinal}) eq 'ARRAY' && @{$TIMEDWAITING{$ordinal}}) { foreach (@{$TIMEDWAITING{$ordinal}}) { ($tid, $l_ordinal) = @{$_}[0,3]; if ($ordinal == $l_ordinal || defined $LOCKED[$l_ordinal]) { unshift( @{$LOCKING[$l_ordinal]}, $tid ); } else { $LOCKED[$l_ordinal] = $tid; $WRITE{$TID2CLIENT{$tid}} = $true; } $TIMEDWAITING_IDX_EXPIRED = 1; } delete $TIMEDWAITING{$ordinal}; } $WRITE{$client} = $undef; } #_broadcast #--------------------------------------------------------------------------- # IN: 1 client socket # 2 thread id that was shutdown sub _shutdown { # Obtain the client socket # Obtain the thread id # If thread did not appear to exit cleanly # Simulate join of the thread with no result # If it is not the main thread shutting down # Unlock all locked variables # Reset one of the following events (as thread can only be in one blocking state) # Try removing TID from @LOCKING # Try removing TID from @WAITING # Try removing TID from %TIMEDWAITING # Delete any messages that might have been pending for this client # Else (it's the main thread shutting down and main thread is parent process) # Update running flag for pending server shutdown # Mark this client for deletion # Send result to thread to allow it to shut down my $client = shift; my $tid = shift; if ((exists $NOTJOINED{$tid} && !exists $RESULT{$tid}) || ($DETACHED =~ m/\b$tid\b/ && exists $DETACHED_NOTDONE{$tid})) { _tojoin($client); #TODO: report error here ($thr->error reportable)? } if ($tid) { while ((my $ordinal = List::MoreUtils::firstidx( sub { defined $_ ? $_ eq $tid : 0 }, @LOCKED)) >= 0) { $RECURSED[$ordinal] = 0; _unlock_ordinal($ordinal); } BLOCKING_EVENT: { if ((my $ordinal = List::MoreUtils::firstidx( sub { ref($_) eq 'ARRAY' ? grep(/^$tid$/, @{$_}) : 0 }, @LOCKING)) >= 0) { $LOCKING[$ordinal] = [grep(!/^$tid$/, @{$LOCKING[$ordinal]})]; last BLOCKING_EVENT; } if ((my $ordinal = List::MoreUtils::firstidx( sub { ref($_) eq 'ARRAY' ? grep(/^$tid$/, @{$_}) : 0 }, @WAITING)) >= 0) { $WAITING[$ordinal] = [grep(!/^$tid$/, @{$WAITING[$ordinal]})]; last BLOCKING_EVENT; } if ((my $ordinal = List::MoreUtils::firstidx( sub { $_->[0] == $tid }, @TIMEDWAITING_IDX)) >= 0) { if ((my $idx = List::MoreUtils::firstidx(sub { $_->[0] == $tid }, @{$TIMEDWAITING{$ordinal}})) >= 0) { splice(@{$TIMEDWAITING{$ordinal}}, $idx, 1); $TIMEDWAITING_IDX_EXPIRED = 1; last BLOCKING_EVENT; } } } } elsif ($THREADS_INTEGRATED_MODEL) { $RUNNING = $client; } $DONEWITH{$client} = undef; $WRITE{$client} = $true; #TODO: make sure socket is still alive, otherwise could cause server to croak on dead socket (need to protect server with correct error state--EPIPE?) } #_shutdown #--------------------------------------------------------------------------- # IN: 1 ordinal number of shared variable to unlock sub _unlock_ordinal { # Obtain the ordinal number # If this is a recursive lock # Remove one recursion # And return my $ordinal = shift; if ($RECURSED[$ordinal]) { $RECURSED[$ordinal]--; return; } # Get random number to determine which lock waiting list to use first # Obtain the thread id, target lock ordinal, response from randomly chosen list # Obtain the information from alternate list if there is no thread id yet my $rand = rand; my ($tid, $l_ordinal, $response) = $rand > 0.5 ? _unlock_ordinal_timedwaiting_expired($ordinal) : _unlock_ordinal_locking($ordinal); ($tid, $l_ordinal, $response) = $rand > 0.5 ? _unlock_ordinal_locking($ordinal) : _unlock_ordinal_timedwaiting_expired($ordinal) unless defined $tid; # If there is a thread id for the lock # Make that the thread locking the variable # And have that thread continue # Else (still no thread wanting to lock) # Just reset the lock for this variable if (defined $tid){ $LOCKED[$l_ordinal] = $tid; $WRITE{$TID2CLIENT{$tid}} = $response; } else { $LOCKED[$l_ordinal] = undef; } } #_unlock_ordinal #--------------------------------------------------------------------------- # IN: 1 ordinal number of shared variable to unlock # OUT: 1 tid to acquire ordinal lock # 2 ordinal being locked # 3 response for waiting thread sub _unlock_ordinal_locking { # Obtain thread id from locking list and return the results return (shift(@{$LOCKING[$_[0]]}), $_[0], $true); } #--------------------------------------------------------------------------- # IN: 1 ordinal number of shared variable to unlock # OUT: 1 tid to acquire ordinal lock # 2 ordinal being locked # 3 response for waiting thread sub _unlock_ordinal_timedwaiting_expired { # Initialize the thread id and target lock ordinal # Initialize default response to true # If there exist any timed waiting events that expired and are waiting to relock # Get the thread id and target lock ordinal # Set response to false (indicating this event timed out) # Else # Assign default target lock ordinal # Returns the results my ($tid, $l_ordinal); my $response = $true; if (ref($TIMEDWAITING_EXPIRED[$_[0]]) eq 'ARRAY' && @{$TIMEDWAITING_EXPIRED[$_[0]]}) { ($tid, $l_ordinal) = @{shift @{$TIMEDWAITING_EXPIRED[$_[0]]}}; $response = $false; } else { $l_ordinal = $_[0]; } return ($tid, $l_ordinal, $response); } #--------------------------------------------------------------------------- # IN: 1 client socket # 2 ordinal number of variable to start waiting for # 3 function name to show when there is an error (undef: no error if wrong) # OUT: 1 ordinal number of variable # 2 thread id that keeps it locked sub _islocked { # Obtain the client socket # Obtain the thread id of the thread # Obtain the ordinal number of the shared variable # If we're not the one locking # Return now with nothing if we don't want an error message # Die (we want an error message) # Return the ordinal number and/or thread id my $client = shift; my $tid = $CLIENT2TID{$client}; my $ordinal = shift; if (!defined $LOCKED[$ordinal] || $tid != $LOCKED[$ordinal]) { return unless $_[0]; _croak( "You need a lock before you can $_[0]: variable #$ordinal ($tid != $LOCKED[$ordinal])" ); } CORE::wantarray ? ($ordinal,$tid) : $ordinal; } #_islocked #--------------------------------------------------------------------------- # IN: 1 client socket to which result will be sent # 2 thread id of thread with result # 3..N the result to be sent sub _isjoined { # Obtain the client # Obtain the thread id my $client = shift; my $tid = shift; # Unblock the client with the result # Forget about that someone is waiting for this thread # Forget about the result (if any) # Forget about listing in ->list if this thread was shutdown already # Mark that thread as joined # Delete thread context information # Delete thread stack size information $WRITE{$client} = _pack_response( [1, @_] ); #warn "case 7: tid $tid had this to say (".scalar(@_)."): ".CORE::join(',', @_); #TODO: for debugging only delete( $BLOCKING_JOIN{$tid} ); delete( $RESULT{$tid} ); delete( $TID2PID{$tid} ) unless exists( $TID2CLIENT{$tid} ); delete( $NOTJOINED{$tid} ); delete( $TID2CONTEXT{$tid} ); delete( $TID2STACKSIZE{$tid} ); } #_isjoined #--------------------------------------------------------------------------- # debugging routines #--------------------------------------------------------------------------- # IN: 1 message to display sub _croak { return &Carp::confess((defined $TID ? $TID : '')." ($$): ".shift) } #_croak #--------------------------------------------------------------------------- # IN: 1 message to log sub _log { # Obtain the message # If it is a thread message # Obtain the thread id # Prefix thread id value # Shorten message if _very_ long # Log it my $message = shift; if (substr($message,0,1) ne ' ') { my $tid = defined($TID) ? $TID : '?'; $message = "$tid $message"; } $message = substr($message,0,256)."... (".(length $message)." bytes)" if length( $message ) > 256; print STDERR "$message\n"; }#_log #--------------------------------------------------------------------------- # IN: 1 client object # OUT: 1 associated tid # 2 associated pid sub _client2tidpid { # Obtain the thread id # Return thread and process id my $tid = $CLIENT2TID{ (shift) }; ($tid,$TID2PID{$tid}); } #_client2tidpid #--------------------------------------------------------------------------- sub _run_CLONE_SKIP { # Prepare hash for results # For every package loaded (including main::) # Initialize code reference # If we tried to get the code reference before (may be undef if not found) # Use that my %result; $result{pkg} = ['main', grep { $_ !~ /^CORE::|::SUPER$/o } forks::Devel::Symdump->rnew->packages]; foreach my $package (@{$result{pkg}}) { my $code; if (exists $CLONE_SKIP{$package}) { $code = $CLONE_SKIP{$package}; # Else # Attempt to obtain the code reference, don't care if failed # Execute the CLONE_SKIP subroutine if found, and save result # Return results } else { $code = $CLONE_SKIP{$package} = eval { $package->can( 'CLONE_SKIP' ) }; } $result{skip}{$package} = $code->($package) if $code; } return \%result; } #_run_CLONE_SKIP #--------------------------------------------------------------------------- sub _run_CLONE { # Load results of _run_CLONE_SKIP # For every package loaded (including main::) # Initialize code reference # If this package CLONE_SKIP returned a true value # Find all blessed objects from this class # First, "damn" object to unbless and prevent DESTROY # Now replace value with an undef SCALAR ref, or undef the existing datastructure # Remove package from tracked entities # Immediately check next package (skip clone) # If we tried to get the code reference before (may be undef if not found) # Use that my $clone = shift || { skip => undef, pkg => ['main', grep { $_ !~ /^CORE::|::SUPER$/o } forks::Devel::Symdump->rnew->packages]}; CLONE_LOOP: foreach my $package (@{$clone->{pkg}}) { my $code; if (exists( $clone->{skip}{$package} ) && $clone->{skip}{$package}) { $CLONE_SKIP_REF{$package} = {} unless $CLONE_SKIP_REF{$package}; while (my ($addr, $ref) = each %{$CLONE_SKIP_REF{$package}}) { my $class = blessed(${$ref}); if ($class && $class eq $package) { Acme::Damn::damn(${$ref}); if (reftype( ${$CLONE_SKIP_REF{$package}{$addr}} ) eq 'HASH') { undef %{${$CLONE_SKIP_REF{$package}{$addr}}}; } elsif (reftype( ${$CLONE_SKIP_REF{$package}{$addr}} ) eq 'ARRAY') { undef @{${$CLONE_SKIP_REF{$package}{$addr}}}; } else { undef ${${$CLONE_SKIP_REF{$package}{$addr}}}; } } } delete $CLONE_SKIP_REF{$package}; next CLONE_LOOP; } elsif (exists $CLONE{$package}) { $code = $CLONE{$package}; # Else # Attempt to obtain the code reference, don't care if failed # Execute the CLONE subroutine if found } else { $code = $CLONE{$package} = eval { $package->can( 'CLONE' ) }; } $code->($package) if $code; } } #_run_CLONE #--------------------------------------------------------------------------- package forks::shared::_preload; # Preload forks::shared for seamless 'require threads::shared' require forks::shared unless exists( $ENV{'THREADS_NO_PRELOAD_SHARED'} ) && $ENV{'THREADS_NO_PRELOAD_SHARED'}; #--------------------------------------------------------------------------- # Satisfy -require- 1; __END__ =pod =head1 NAME forks - drop-in replacement for Perl threads using fork() =head1 VERSION This documentation describes version 0.34. =head1 SYNOPSIS use forks; #ALWAYS LOAD AS FIRST MODULE, if possible use warnings; my $thread = threads->new( sub { # or ->create or async() print "Hello world from a thread\n"; } ); $thread->join; $thread = threads->new( { 'context' => 'list' }, sub { print "Thread is expected to return a list\n"; return (1, 'abc', 5); } my @result = $thread->join(); threads->detach; $thread->detach; my $tid = $thread->tid; my $owntid = threads->tid; my $self = threads->self; my $threadx = threads->object( $tidx ); my @running = threads->list(threads::running); $_->join() foreach (threads->list(threads::joinable)); $_->join foreach threads->list; #block until all threads done unless (fork) { threads->isthread; # could be used a child-init Apache handler } # Enable debugging use forks qw(debug); threads->debug( 1 ); # Stringify thread objects use forks qw(stringify); # Check state of a thread my $thr = threads->new( ... ); if ($thr->is_running()) { print "Thread $thr running\n"; #prints "Thread 1 running" } # Send a signal to a thread $thr->kill('SIGUSR1'); # Manual deadlock detection if ($thr->is_deadlocked()) { print "Thread $thr is currently deadlocked!\n"; } # Use forks as a drop-in replacement for an ithreads application perl -Mforks threadapplication See L for more examples. =head1 DESCRIPTION The "forks" pragma allows a developer to use threads without having to have a threaded perl, or to even run 5.8.0 or higher. Refer to the L module for ithreads API documentation. Also, use perl -Mforks -e 'print $threads::VERSION' to see what version of L you should refer to regarding supported API features. There were a number of goals that I am trying to reach with this implementation. =over 2 Using this module B makes sense if you run on a system that has an implementation of the C function by the Operating System. Windows is currently the only known system on which Perl runs which does B have an implementation of C. Therefore, it B make any sense to use this module on a Windows system. And therefore, a check is made during installation barring you from installing on a Windows system. =back =head2 module load order: forks first Since forks overrides core Perl functions, you are *strongly* encouraged to load the forks module before any other Perl modules. This will insure the most consistent and stable system behavior. This can be easily done without affecting existing code, like: perl -Mforks script.pl =head2 memory usage The standard Perl 5.8.0 threads implementation is B memory consuming, which makes it basically impossible to use in a production environment, particularly with mod_perl and Apache. Because of the use of the standard Unix fork() capabilities, most operating systems will be able to use the Copy-On-Write (COW) memory sharing capabilities (whereas with the standard Perl 5.8.0 threads implementation, this is thwarted by the Perl interpreter cloning process that is used to create threads). The memory savings have been confirmed. =head2 mod_perl / Apache This threads implementation allows you to use a standard, pre-forking Apache server and have the children act as threads (with the class method L). =head2 same API as threads You should be able to run threaded applications unchanged by simply making sure that the "forks" and "forks::shared" modules are loaded, e.g. by specifying them on the command line. Forks is currently API compatible with CPAN L version C<1.53>. Additionally, you do not need to worry about upgrading to the latest Perl maintenance release to insure that the (CPAN) release of threads you wish to use is fully compatibly and stable. Forks code is completely independent of the perl core, and thus will guarantee reliable behavior on any release of Perl 5.8 or later. (Note that there may be behavior variances if running under Perl 5.6.x, as that version does not support safe signals and requires a source filter to load forks). =head2 using as a development tool Because you do not need a threaded Perl to use forks.pm, you can start prototyping threaded applications with the Perl executable that you are used to. Just download and install the "forks" package from CPAN. So the threshold for trying out threads in Perl has become much lower. Even Perl 5.005 should, in principle, be able to support the forks.pm module; however, some issues with regards to the availability of XS features between different versions of Perl, it seems that 5.6.0 (unthreaded) is what you need at least. Additionally, forks offers a full thread deadlock detection engine, to help discover and optionally resolve locking issues in threaded applications. See L for more information. =head2 using in production environments This package has successfully been proven as stable and reliable in production environments. I have personally used it in high-availability, database-driven, message processing server applications since 2004 with great success. Also, unlike pure ithreads, forks.pm is fully compatible with all perl modules, whether or not they have been updated to be ithread safe. This means that you do not need to feel limited in what you can develop as a threaded perl application, a problem that continues to plague the acceptance of ithreads in production enviroments today. Just handle these modules as you would when using a standard fork: be sure to create new instances of, or connections to, resources where a single instance can not be shared between multiple processes. The only major concern is the potentially slow (relative to pure ithreads) performance of shared data and locks. If your application doesn't depend on extensive semaphore use, and reads/writes from shared variables moderately (such as using them primarily to deliver data to a child thread to process and the child thread uses a shared structure to return the result), then this will likely not be an issue for your application. See the TODO section regarding plans to tackle this issue. Also, you may wish to try L, which has shown signifigant performance gains and consistent throughoutput in high-concurrency shared variable applications. =head2 Perl built without native ithreads If your Perl release was not built with ithreads or does not support ithreads, you will have a compile-time option of installing forks into the threads and threads::shared namespaces. This is done as a convenience to give users a reasonably seamless ithreads API experience without having to rebuild their distribution with native threading (and its slight performance overhead on all perl runtime, even if not using threads). B When using forks in this manner (e.g. "use threads;") for the first time in your code, forks will attempt to behave identically to threads relative to the current version of L it supports (refer to $threads::VERSION), even if the behavior is (or was) considered a bug. At this time, this means that shared variables will lose their pre-existing value at the time they are shared and that splice will die if attempted on a shared scalar. If you use forks for the first time as "use forks" and other loaded code uses "use threads", then this threads behavior emulation does not apply. =head1 REQUIRED MODULES Acme::Damn (any) Attribute::Handlers (any) Devel::Symdump (any) File::Spec (any) if (any) IO::Socket (1.18) List::MoreUtils (0.15) Scalar::Util (1.11) Storable (any) Sys::SigAction (0.11) Test::More (any) Time::HiRes (any) =head1 IMPLEMENTATION This version is mostly written in Perl. Inter-process communication is done by using sockets, with the process that stores the shared variables as the server and all the processes that function as threads, as clients. =head2 why sockets? The reason I chose sockets for inter-thread communication above using a shared memory library, is that a blocking socket allows you to elegantly solve the problem of a thread that is blocking for a certain event. Any polling that might occur, is not occurring at the Perl level, but at the level of the socket, which should be much better and probably very optimized already. =head1 EXTRA CLASS METHODS Apart from the standard class methods, the following class methods are supplied by the "forks" threads implementation. =head2 isthread unless (fork) { threads->isthread; # this process is a detached thread now exit; # can not return values, as thread is detached } The C class method attempt to make a connection with the shared variables process. If it succeeds, then the process will function as a detached thread and will allow all the threads methods to operate. This method is mainly intended to be used from within a child-init handler in a pre-forking Apache server. All the children that handle requests become threads as far as Perl is concerned, allowing you to use shared variables between all of the Apache processes. See L for more information. =head2 debug threads->debug( 1 ); $debug = threads->debug; The "debug" class method allows you to (re)set a flag which causes extensive debugging output of the communication between threads to be output to STDERR. The format is still subject to change and therefore still undocumented. Debugging can B be switched on by defining the environment variable C. If the environment variable does not exist when the forks.pm module is compiled, then all debugging code will be optimised away to create a better performance. If the environment variable has a true value, then debugging will also be enabled from the start. =head1 EXTRA FEATURES =head2 Native threads 'to-the-letter' emulation mode By default, forks behaves slightly differently than native ithreads, regarding shared variables. Specifically, native threads does not support splice() on shared arrays, nor does it retain any pre-existing values of arrays or hashes when they are shared; however, forks supports all of these functions. These are behaviors are considered limitations/bugs in the current native ithread implementation. To allow for complete drop-in compatibility with scripts and modules written for threads.pm, you may specify the environment variable C to a true value before running your script. This will instruct forks to behave exactly as native ithreads would in the above noted situations. This mode may also be enabled by default (without requiring this environment variable if you do not have a threaded Perl and wish to install forks as a full drop-in replacement. See L for more information. =head2 Deadlock detection Forks also offers a full thread deadlock detection engine, to help discover and optionally resolve locking issues in threaded applications. See L for more information. =head2 Perl debugger support Forks supports basic compabitility with the Perl debugger. By default, only the main thread to the active terminal (TTY), allowing for debugging of scripts where child threads are run as background tasks without any extra steps. If you wish to debug code executed in child threads, you may need to perform a few steps to prepare your environment for multi-threaded debugging. The simplest option is run your script in xterm, as Perl will automatically create additional xterm windows for each child thread that encounters a debugger breakpoint. Otherwise, you will need to manually tell Perl how to map a control of thread to a TTY. Two undocumented features exist in the Perl debugger: 1. Define global variable C<$DB::fork_TTY> as the first stem in the subroutine for a thread. The value must be a valid TTY name, such as '/dev/pts/1' or '/dev/ttys001'; valid names may vary across platforms. For example: threads->new(sub { $DB::fork_TTY = '/dev/tty003'; #tie thread to TTY 3 ... }); Also, the TTY must be active and idle prior to the thread executing. This normally is accomplished by opening a new local or remote session to your machine, identifying the TTY via `tty`, and then typing `sleep 10000000` to prevent user input from being passed to the command line while you are debugging. When the debugger halts at a breakpoint in your code in a child thread, all output and user input will be managed via this TTY. 2. Define subroutine DB::get_fork_TTY() This subroutine will execute once each child thread as soon as it has spawned. Thus, you can create a new TTY, or simply bind to an existng, active TTY. In this subroutine, you should define a unique, valid TTY name for the global variable C<$DB::fork_TTY>. For example, to dynamically spawn a new xterm session and bind a new thread to it, you could do the following: sub DB::get_fork_TTY { open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty1>&3;\ sleep 10000000' |]; $DB::fork_TTY = ; chomp $DB::fork_TTY; } For more information and tips, refer to this excellent Perl Monks thread: L<Debugging Several Proccesses at Same Time>. =head2 INET socket IP mask For security, inter-thread communication INET sockets only will allow connections from the default local machine IPv4 loopback address (e.g 127.0.0.1). However, this filter may be modified by defining the environment variable C with a standard perl regular expression (or with no value, which would disable the filter). =head2 UNIX socket support For users who do not wish to (or can not) use TCP sockets, UNIX socket support is available. This can be B switched on by defining the environment variable C. If the environment variable has a true value, then UNIX sockets will be used instead of the default TCP sockets. Socket descriptors are currently written to /var/tmp and given a+rw access by default (for cleanest functional support on multi-user systems). This feature is excellent for applications that require extra security, as it does not expose forks.pm to any INET vunerabilities your system may be subject to (i.e. systems not protected by a firewall). It also may provide an additional performance boost, as there is less system overhead necessary to handle UNIX vs INET socket communication. =head2 Co-existance with fork-aware modules and environments For modules that actively monitor and clean up after defunct child processes like L, forks has added support to switch the methodology used to maintain thraad group state. This feature is switched on by defining the environment variable C. An example use might be: THREADS_DAEMON_MODEL=1 perl -Mforks -MPOE threadapplication This function essentially reverses the parent-child relationship between the main thread and the thread state process that forks.pm uses. Extra care has gone into retaining full system signal support and compatibility when using this mode, so it should be quite stable. =head1 NOTES Some important items you should be aware of. =head2 Signal behavior Unlike ithreads, signals being sent are standard OS signals, so you should program defensively if you plan to use inter-thread signals. Also, be aware that certain signals may untrappable depending on the target platform, such as SIGKILL and SIGSTOP. Thus, it is recommended you only use normal signals (such as TERM, INT, HUP, USR1, USR2) for inter-thread signal handling. =head2 exit() behavior If you call exit() in a thread other than the main thread and exit behavior is configured to cause entire application to exit (default behavior), be aware that all other threads will be agressively terminated using SIGKILL. This will cause END blocks and global destruction to be ignored in those threads. This behavior conforms to the expected behavior of native Perl threads. The only subtle difference is that the main thread will be signaled using SIGABRT to immediately exit. If you call C but do not call isthread()>, then the child process will default to the pre-existing CORE::GLOBAL::exit() or CORE::exit() behavior. Note that such processes are exempt from application global termination if exit() is called in a thread, so you must manually clean up child processes created in this manner before exiting your threaded application. =head2 END block behavior In native ithreads, END blocks are only executed in the thread in which the code was loaded/evaluated. However, in forks, END blocks are processed in all threads that are aware of such code segments (i.e. threads started after modules with END blocks are loaded). This may be considered a bug or a feature depending on what your END blocks are doing, such as closing important external resources for which each thread may have it's own handle. In general, it is a good defensive programming practice to add the following to your END blocks when you want to insure sure they only are evaluated in the thread that they were created in: { my $tid = threads->tid if exists $INC{'threads.pm'}; END { return if defined($tid) && $tid != threads->tid; # standard end block code goes here } } This code is completely compatible with native ithreads. Note that this behavior may change in the future (at least with THREADS_NATIVE_EMULATION mode). =head2 Modifying signals Since the threads API provides a method to send signals between threads (processes), untrapped normal and error signals are defined by forks with a basic exit() shutdown function to provide safe termination. Thus, if you (or any modules you use) modify signal handlers, it is important that the signal handlers at least remain defined and are not undefined (for whatever reason). The system signal handler default, usually abnormal process termination which skips END blocks, may cause undesired behavior if a thread exits due to an unhandled signal. In general, the following signals are considered "safe" to trap and use in threads (depending on your system behavior when such signals are trapped): HUP INT PIPE TERM USR1 USR2 ABRT EMT QUIT TRAP =head2 Modules that modify %SIG or use POSIX::sigaction() To insure highest stability, forks ties some hooks into the global %SIG hash to co-exist as peacefully as possible with user-defined signals. This has a few subtle, but important implications: - As long as you modify signals using %SIG, you should never encounter any unexpected issues. - If you use POSIX::sigaction, it may subvert protections that forks has added to the signal handling system. In normal circumstances, this will not create any run-time issues; however, if you also attempt to access shared variables in signal handlers or END blocks, you may encounter unexpected results. Note: if you do use sigaction, please avoid overloading the ABRT signal in the main thread, as it is used for process group flow control. =head2 Modules that modify $SIG{CHLD} In order to be compatible with perl's core system() function on all platforms, extra care has gone into implementing a smarter $SIG{CHLD} in forks.pm. The only functional effect is that you will never need to (or be able to) reap threads (processes) if you define your own CHLD handler. You may define the environment variable THREADS_SIGCHLD_IGNORE to to force forks to use 'IGNORE' on systems where a custom CHLD signal handler has been automatically installed to support correct exit code of perl core system() function. Note that this should *not* be necessary unless you encounter specific issues with the forks.pm CHLD signal handler. =head2 $thr->wantarray() returns void after $thr->join or $thr->detach Be aware that thread return context is purged and $thr->wantarray will return void context after a thread is detached or joined. This is done to minimize memory in programs that spawn many (millions of) threads. This differs from default threads.pm behavior, but should be acceptable as the context no longer serves a functional purpose after a join or detach. Thus, if you still require thread context information after a join, be sure to request and store the value of $thr->wantarray first. =head2 $thr->get_stack_size() returns default after $thr->join or $thr->detach Thread stack size information is purged and $thr->get_stack_size will return the current threads default after a thread is detached or joined. This is done to minimize memory in programs that spawn many (millions of) threads. This differs from default threads.pm behavior, which retains per-thread stack size information indefinitely. Thus, if you require individual thread stack size information after a join or detach, be sure to request and store the value of $thr->get_stack_size first. =head2 Modules that modify CORE::GLOBAL::fork() This modules goes to great lengths to insure that normal fork behavior is seamlessly integrated into the threaded environment by overloading CORE::GLOBAL::fork. Thus, please refrain from overloading this function unless absolutely necessary. In such a case, forks.pm provides a set of four functions: _fork_pre _fork _fork_post_parent _fork_post_child that represent all possible functional states before and after a fork occurs. These states must be called to insure that fork() works for both threads and normal fork calls. Refer to forks.pm source code, *CORE::GLOBAL::fork = sub { ... } definition as an example usage. Please contact the author if you have any questions regarding this. =head1 CAVEATS Some caveats that you need to be aware of. =head2 Greater latency Because of the use of sockets for inter-thread communication, there is an inherent larger latency with the interaction between threads. However, the fact that TCP sockets are used, may open up the possibility to share threads over more than one physical machine. You may decrease some latency by using UNIX sockets (see L). Also, you may wish to try L, which has shown signifigant performance gains and consistent throughoutput in applications requiring high-concurrency shared variable access. =head2 Module CLONE & CLONE_SKIP functions and threads In rare cases, module CLONE functions may have issues when being auto-executed by a new thread (forked process). This only affects modules that use XS data (objects or struts) created by to external C libraries. If a module attempts to CLONE non-fork safe XS data, at worst it may core dump only the newly created thread (process). If CLONE_SKIP function is defined in a package and it returns a true value, all objects of this class type will be undefined in new threads. This is generally the same behavior as native threads with Perl 5.8.7 and later. See <perlmod> for more information. However, two subtle behavior variances exist relative to native Perl threads: 1. The actual undefining of variables occurs in the child thread. This should be portable with all non-perl modules, as long as those module datastructures can be safely garbage collected in the child thread (note that DESTROY will not be called). 2. Arrays and hashes will be emptied and unblessed, but value will not be converted to an undef scalar ref. This differs from native threads, where all references become an undef scalar ref. This should be generally harmless, as long as you are careful with variable state checks (e.g. check whether reference is still blessed, not whether the reftype has changed, to determine if it is still a valid object in a new thread). Overall, if you treat potentially sensitive resources (such as L driver instances) as non-thread-safe by default and close these resources prior to creating a new thread, you should never encounter any portability issues. =head2 Can't return unshared filehandles from threads Currently, it is not possible to return a file handle from a thread to the thread that is joining it. Attempting to do so will throw a terminal error. However, if you share the filehandle first with L, you can safely return the shared filehandle. =head2 Signals and safe-signal enabled Perl In order to use signals, you must be using perl 5.8 compiled with safe signal support. Otherwise, you'll get a terminal error like "Cannot signal threads without safe signals" if you try to use signal functions. =head2 Source filter To get forks.pm working on Perl 5.6.x, it was necessary to use a source filter to ensure a smooth upgrade path from using forks under Perl 5.6.x to Perl 5.8.x and higher. The source filter used is pretty simple and may prove to be too simple. Please report any problems that you may find when running under 5.6.x. =head1 TODO See the TODO file in the distribution. =head1 KNOWN PROBLEMS These problems are known and will hopefully be fixed in the future: =over 2 =item test-suite exits in a weird way Although there are no errors in the test-suite, the test harness sometimes thinks there is something wrong because of an unexpected exit() value. This is an issue with Test::More's END block, which wasn't designed to co-exist with a threads environment and forked processes. Hopefully, that module will be patched in the future, but for now, the warnings are harmless and may be safely ignored. And of course, there might be other, undiscovered issues. Patches are welcome! =back =head1 CREDITS Refer to the C file included in the distribution. =head1 CURRENT AUTHOR AND MAINTAINER Eric Rybski . Please send all module inquries to me. =head1 ORIGINAL AUTHOR Elizabeth Mattijsen, . =head1 COPYRIGHT Copyright (c) 2005-2010 Eric Rybski , 2002-2004 Elizabeth Mattijsen . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L. =cut forks-0.34/lib/threads/0040755000076500000240000000000011405351363012724 5ustar gamesforks-0.34/lib/threads/shared/0040755000076500000240000000000011405351363014172 5ustar gamesforks-0.34/lib/threads/shared/array.pm0100755000076500000240000001034411405351166015651 0ustar gamespackage threads::shared::array; # Make sure we have version info for this module # Make sure we do everything by the book from now on $VERSION = '0.34'; use strict; use Scalar::Util; # Satisfy -require- 1; #--------------------------------------------------------------------------- # standard Perl features #--------------------------------------------------------------------------- # IN: 1 class for which to bless # 2..N initial values # OUT: 1 instantiated object sub TIEARRAY { my $class = shift; bless \do{ my $o = @_ && Scalar::Util::reftype($_[0]) eq 'ARRAY' ? $_[0] : [] },$class } #TIEARRAY #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 index of element to fetch # OUT: 1 value of element sub FETCH { ${$_[0]}->[$_[1]] } #FETCH #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 number of elements sub FETCHSIZE { scalar @{${$_[0]}} } #FETCHSIZE #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 index for which to store # 3 new value sub STORE { ${$_[0]}->[$_[1]] = $_[2] } #STORE #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 new number of elements sub STORESIZE { $#{${$_[0]}} = $_[1]-1 } #STORESIZE #--------------------------------------------------------------------------- # IN: 1 instantiated object sub CLEAR { @{${$_[0]}} = () } #CLEAR #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 popped off value sub POP { pop(@{${$_[0]}}) } #POP #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2..N values to push sub PUSH { my $self = shift; push( @{${$self}},@_ ) } #PUSH #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 shifted off value sub SHIFT { shift(@{${$_[0]}}) } #SHIFT #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2..N values to unshift sub UNSHIFT { my $self = shift; unshift( @{${$self}},@_ ) } #UNSHIFT #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 offset (index) from which to splice (default: 0) # 3 number of elements to remove (default: rest) # 4..N values to to put in place # OUT: 1..N elements that were removed sub SPLICE { # Obtain the object # Obtain the array object # Obtain the current size of the list # Obtain the offset to use # Adapt if it was to be relative from the end # Obtain the number of element to remove my $self = shift; my $list = ${$self}; my $size = $self->FETCHSIZE; my $offset = @_ ? shift : 0; $offset += $size if $offset < 0; my $length = @_ ? shift : $size - $offset; # Perform the actual action and return its result splice( @$list, $offset, $length, @_ ); } #SPLICE #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 index of element to check # OUT: 1 flag: whether element exists sub EXISTS { exists ${$_[0]}->[$_[1]] } #EXISTS #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 index of element to delete sub DELETE { delete ${$_[0]}->[$_[1]] } #DELETE #--------------------------------------------------------------------------- __END__ =head1 NAME threads::shared::array - default class for tie-ing arrays to threads with forks =head1 DESCRIPTION Helper class for L. See documentation there. =head1 ORIGINAL AUTHOR CREDITS Implementation inspired by L. =head1 CURRENT AUTHOR AND MAINTAINER Eric Rybski . =head1 ORIGINAL AUTHOR Elizabeth Mattijsen, . =head1 COPYRIGHT Copyright (c) 2005-2010 Eric Rybski , 2002-2004 Elizabeth Mattijsen . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L. =cut forks-0.34/lib/threads/shared/handle.pm0100755000076500000240000001167311405351166015774 0ustar gamespackage threads::shared::handle; # Make sure we have version info for this module # Make sure we do everything by the book from now on $VERSION = '0.34'; use strict; # Satisfy -require- 1; #--------------------------------------------------------------------------- # standard Perl features #--------------------------------------------------------------------------- # IN: 1 class for which to bless # 2..N any parameters passed to open() # OUT: 1 instantiated object sub TIEHANDLE { # Obtain the class # Obtain a reference to an undefined scalar # Bless it so we can use it to call ourselves my $class = shift; my $handle = \do{ my $o = \do { local *TIEHANDLE } }; # basically rw \undef bless $handle,$class; # Open it if there are any parameters # Return the instantiated object $handle->OPEN( @_ ) if @_; $handle; } #TIEHANDLE #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 flag: whether at end of file sub EOF { eof( ${$_[0]} ) } #EOF #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 position at which the filepointer is located sub TELL { tell( ${$_[0]} ) } #TELL #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 fileno of handle sub FILENO { fileno( ${$_[0]} ) } #FILENO #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 position to seek to # 3 type of offset # OUT: 1 result of seek() sub SEEK { seek( ${$_[0]},$_[1],$_[2] ) } #SEEK #--------------------------------------------------------------------------- # IN: 1 instantiated object sub CLOSE { close( ${$_[0]} ) } #CLOSE #--------------------------------------------------------------------------- # IN: 1 instantiated object sub BINMODE { binmode( ${$_[0]} ) } #BINMODE #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2..N any parameters passed to open() # OUT: 1 result of open() sub OPEN { # Close any file that is already opened here # Perform a 2 or 3 argument open and return the result ${$_[0]}->CLOSE if defined(${$_[0]}->FILENO); @_ == 2 ? open( ${$_[0]}, $_[1] ) : open( ${$_[0]},$_[1],$_[2] ); } #OPEN #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 reference to scalar to read into # 3 number of bytes/characters to read # 4 offset into variable sub READ { read( ${$_[0]},$_[1],$_[2] ) } #READ #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 line read sub READLINE { scalar(readline( ${$_[0]} )) } #READLINE #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 character read sub GETC { getc( ${$_[0]} ) } #GETC #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2..N stuff to print # OUT: 1 result sub PRINT { # Obtain the object # Get local copy of what needs to be printed including extra $\ if needed # Write the stuff that we need and return the result my $self = shift; my $buffer = join( $, || '',@_,'' ); # || to calm if $, is undef in -w $self->WRITE( $buffer,length($buffer),0 ); } #PRINT #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 format with which to printf # 3..N stuff to print # OUT: 1 result sub PRINTF { # Obtain the object # Get the stuff in the right format # Write the stuff that we need and return the result my $self = shift; my $buffer = sprintf( shift,@_ ); # can't use @_ because of tokenization $self->WRITE( $buffer,length($buffer),0 ); } #PRINTF #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 reference to scalar to write from # 3 number of bytes/characters to write # 4 offset into variable # OUT: 1 number of bytes/characters written sub WRITE { syswrite( ${$_[0]},$_[1],$_[2],$_[3] ) } #WRITE #--------------------------------------------------------------------------- __END__ =head1 NAME threads::shared::handle - default class for tie-ing handles to threads with forks =head1 DESCRIPTION Helper class for L. See documentation there. =head1 ORIGINAL AUTHOR CREDITS Implementation inspired by L. =head1 CURRENT AUTHOR AND MAINTAINER Eric Rybski . =head1 ORIGINAL AUTHOR Elizabeth Mattijsen, . =head1 COPYRIGHT Copyright (c) 2005-2010 Eric Rybski , 2002-2004 Elizabeth Mattijsen . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L. =cut forks-0.34/lib/threads/shared/hash.pm0100755000076500000240000000555111405351166015462 0ustar gamespackage threads::shared::hash; # Make sure we have version info for this module # Make sure we do everything by the book from now on $VERSION = '0.34'; use strict; use Scalar::Util; # Satisfy -require- 1; #--------------------------------------------------------------------------- # standard Perl features #--------------------------------------------------------------------------- # IN: 1 class for which to bless # 2..N key-value pairs to initialize with # OUT: 1 instantiated object sub TIEHASH { my $class = shift; bless \do{ my $o = @_ && Scalar::Util::reftype($_[0]) eq 'HASH' ? $_[0] : {} },$class } #TIEHASH #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 key of element to fetch # OUT: 1 value of element sub FETCH { ${$_[0]}->{$_[1]} } #FETCH #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 key for which to store # 3 new value sub STORE { ${$_[0]}->{$_[1]} = $_[2] } #STORE #--------------------------------------------------------------------------- # IN: 1 instantiated object sub CLEAR { %{${$_[0]}} = () } #CLEAR #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 first key of hash # 2 value associated with first key sub FIRSTKEY { # Reset the each() magic # Return first key/value pair scalar( keys %{${$_[0]}} ); each %{${$_[0]}}; } #FIRSTKEY #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 next key of hash # 2 value associated with next key sub NEXTKEY { each %{${$_[0]}} } #NEXTKEY #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 key of element to check # OUT: 1 flag: whether element exists sub EXISTS { exists ${$_[0]}->{$_[1]} } #EXISTS #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 key of element to delete sub DELETE { delete ${$_[0]}->{$_[1]} } #DELETE #--------------------------------------------------------------------------- __END__ =head1 NAME threads::shared::hash - default class for tie-ing hashes to threads with forks =head1 DESCRIPTION Helper class for L. See documentation there. =head1 ORIGINAL AUTHOR CREDITS Implementation inspired by L. =head1 CURRENT AUTHOR AND MAINTAINER Eric Rybski . =head1 ORIGINAL AUTHOR Elizabeth Mattijsen, . =head1 COPYRIGHT Copyright (c) 2005-2010 Eric Rybski , 2002-2004 Elizabeth Mattijsen . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L. =cut forks-0.34/lib/threads/shared/scalar.pm0100755000076500000240000000344011405351166015777 0ustar gamespackage threads::shared::scalar; # Make sure we have version info for this module # Make sure we do everything by the book from now on $VERSION = '0.34'; use strict; use Scalar::Util; # Satisfy -require- 1; #--------------------------------------------------------------------------- # standard Perl features #--------------------------------------------------------------------------- # IN: 1 class for which to bless # 2 initial value # OUT: 1 instantiated object sub TIESCALAR { # Obtain the class # Obtain the initial value # Return it as a blessed object my $class = shift; bless \do{ my $o = @_ && Scalar::Util::reftype($_[0]) eq 'SCALAR' ? $_[0] : \(my $s) },$class; } #TIESCALAR #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 value sub FETCH { ${${$_[0]}} } #FETCH #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 new value sub STORE { ${${$_[0]}} = $_[1] } #STORE #--------------------------------------------------------------------------- __END__ =head1 NAME threads::shared::scalar - default class for tie-ing scalars to threads with forks =head1 DESCRIPTION Helper class for L. See documentation there. =head1 ORIGINAL AUTHOR CREDITS Implementation inspired by L. =head1 CURRENT AUTHOR AND MAINTAINER Eric Rybski . =head1 ORIGINAL AUTHOR Elizabeth Mattijsen, . =head1 COPYRIGHT Copyright (c) 2005-2010 Eric Rybski , 2002-2004 Elizabeth Mattijsen . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L. =cut forks-0.34/Makefile.PL0100755000076500000240000001322411166621310012474 0ustar gamesrequire 5.006; BEGIN { die "'forks' is currently not supported on this system (Win32).\n" if ($^O =~ m#Win32# or $ENV{THIS_IS_WIN32}); } #BEGIN use strict; use ExtUtils::MakeMaker 6.10; eval "use Devel::Required"; ### Perl version-specific code modifications and modified requirements ### my $old = 'forks.xs'; my $new = "$old.new";; my @from = ( qq{# PROTOTYPE: \\[\$\@\%]\n}, qq{# PROTOTYPE: \\[\$\@\%];\\[\$\@\%]\n}, qq{# PROTOTYPE: \\[\$\@\%]\$;\\[\$\@\%]\n} ); my @to = ( qq{ PROTOTYPE: \\[\$\@\%]\n}, qq{ PROTOTYPE: \\[\$\@\%];\\[\$\@\%]\n}, qq{ PROTOTYPE: \\[\$\@\%]\$;\\[\$\@\%]\n} ); my @extra_prereq; if ($] < 5.008) { # no complex prototypes before 5.8.0, we need to filter also my @from_tmp = @from; @from = @to; @to = @from_tmp; push @extra_prereq,qw(Filter::Util::Call 0); } warn "Fixing prototypes in $old\n"; open my $in,'<',$old or die "Could not open $old: $!\n";; open my $out,'>',$new or die "Could not create $new: $!\n";; while (<$in>) { my $filtered = 0; for (my $i = 0; $i < scalar @from; $i++) { if ($_ eq $from[$i]) { print $out $to[$i]; $filtered = 1; last; } } print $out $_ unless $filtered; } close $out or die "Could not close $new: $!\n"; close $in or die "Could not close $old: $!\n"; chmod 0644, $old or die "Could not change permissions on $old\n"; unlink $old or die "Could not remove $old\n"; rename $new,$old or die "Could not rename $new to $old\n"; chmod 0444, $old or die "Could not change permissions on $old\n"; ### Determine whether ithreads simulated feature may be used ### use Config (); my $simulate_useithreads = 0; unless ($Config::Config{useithreads}) { # Taken from ExtUtils::MakeMaker 6.16 (Michael Schwern) so that # the prompt() function can be emulated for older versions of ExtUtils::MakeMaker. my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)); if ($isa_tty) { print "\nIt appears your perl was not built with native ithreads.\n" ."\nWould you like to create references to forks, such that\n" ."using 'use threads' and 'use threads::shared' will quietly\n" ."load forks and forks::shared? [no] "; if ( =~ /^y(?:es)?$/i) { $simulate_useithreads = 1; print "\n"; print "NOTE: Be sure to 'make install UNINST=1' when installing\n" ." module to insure that old threads.pm modules do not\n" ." shadow the new forks modules.\n"; print "\n"; } } } if ($simulate_useithreads) { # eval { #package MY; # so that "SUPER" works right #sub all_target { # my $inherited = shift->SUPER::all_target(@_); # $inherited .= # qq{\t-(\$(TEST_F) blib/lib/threads.pm && \$(RM_F) blib/lib/threads.pm) || \$(NOOP)\n} # .qq{\t-(\$(TEST_F) blib/lib/threads/shared.pm && \$(RM_F) blib/lib/threads/shared.pm) || \$(NOOP)\n} # .qq{\t-\$(CP) blib/lib/forks.pm blib/lib/threads.pm\n} # .qq{\t-\$(CP) blib/lib/forks/shared.pm blib/lib/threads/shared.pm\n} # .qq{\t-\$(TEST_F) blib/lib/threads.pm && perl -pi -e 's\/(\\\$\$forks::threads_override =\\s*) 0;\/\$\$1 1;\/' blib/lib/threads.pm || \$(NOOP)\n}; # $inherited; #}; # }; # eval { require ExtUtils::MM_Any; #kludge: MY::all_target doesn't work (as of MakeMaker 6.17) require ExtUtils::MM_Unix; *ExtUtils::MM_Any::__all_target = \&ExtUtils::MM_Any::all_target; *ExtUtils::MM_Unix::__all_target = \&ExtUtils::MM_Unix::all_target; *ExtUtils::MM_Any::all_target = *ExtUtils::MM_Unix::all_target = sub { my $inherited = shift->__all_target(@_); $inherited .= qq{\t-(\$(TEST_F) blib/lib/threads.pm && \$(RM_F) blib/lib/threads.pm) || \$(NOOP)\n} .qq{\t-(\$(TEST_F) blib/lib/threads/shared.pm && \$(RM_F) blib/lib/threads/shared.pm) || \$(NOOP)\n} .qq{\t-\$(CP) blib/lib/forks.pm blib/lib/threads.pm\n} .qq{\t-\$(CP) blib/lib/forks/shared.pm blib/lib/threads/shared.pm\n} .qq{\t-\$(TEST_F) blib/lib/threads.pm && perl -pi -e 's\/(\\\$\$forks::threads_override =\\s*) 0;\/\$\$1 1;\/' blib/lib/threads.pm || \$(NOOP)\n}; $inherited; #}; }; } my $storable_min_version = 0; if (eval{require Storable; $Storable::VERSION < 2.05}) { my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)); if ($isa_tty) { print "\nYou have Storable version $Storable::VERSION, but version\n" ."2.05 or later is required to be able to store CODE refs in\n" ."forks::shared shared variables. Do you wish to install a more\n" ."recent version of Storable at this time? [no] "; if ( =~ /^y(?:es)?$/i) { $storable_min_version = 2.05; print "\nStorable 2.05 will be added to list of install requirements.\n"; print "\n"; } } } ### Standard MakeMaker Makefile.PL directives ### package main; WriteMakefile ( NAME => "forks", AUTHOR => 'Eric Rybski (rybskej@yahoo.com)', ABSTRACT => 'forks - emulate threads with fork', VERSION_FROM => 'lib/forks.pm', PREREQ_PM => {@extra_prereq,qw( Acme::Damn 0 Attribute::Handlers 0 Devel::Symdump 0 List::MoreUtils 0.15 File::Spec 0 if 0 IO::Socket 1.18 Scalar::Util 1.11 Storable ), $storable_min_version, qw( Sys::SigAction 0.11 Test::More 0 Time::HiRes 0 )}, (MM->can('signature_target') ? (SIGN => 1) : ()), ); forks-0.34/MANIFEST0100755000076500000240000000112611405350321011646 0ustar gamesCHANGELOG CREDITS forks.xs lib/forks.pm lib/forks/Devel/Symdump.pm lib/forks/shared.pm lib/forks/shared/attributes.pm lib/forks/shared/global_filter.pm lib/forks/signals.pm lib/threads/shared/array.pm lib/threads/shared/handle.pm lib/threads/shared/hash.pm lib/threads/shared/scalar.pm Makefile.PL MANIFEST MANIFEST.skip META.yml Module meta-data (added by MakeMaker) ppport.h README SIGNATURE t/forks00-requirements.t t/forks00-sigtrap.t t/forks01.t t/forks02.t t/forks03.t t/forks04.t t/forks05.t t/forks06.t t/forks07.t t/forks08.t t/forks09.t t/forks10.t t/forks20.t t/forks99.t TODO VERSION forks-0.34/MANIFEST.skip0100644000076500000240000000101710657632160012623 0ustar games# void version control files. \bRCS\b \bCVS\b \bSCCS\b ,v$ \B\.svn\b \b_darcs\b \.#.+\d+$ # Avoid Makemaker generated and utility files. \bMANIFEST\.bak \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib\.ts$ \bpm_to_blib$ \bblibdirs\.ts$ # 6.18 through 6.25 generated this # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# \.bak$ \.orig$ # Avoid Devel::Cover files. \bcover_db\b # Avoid forks compiled files \bforks\.bs$ \bforks\.c$ \bforks\.o$ forks-0.34/META.yml0100644000076500000240000000155111405351363011774 0ustar games--- #YAML:1.0 name: forks version: 0.34 abstract: forks - emulate threads with fork author: - Eric Rybski (rybskej@yahoo.com) license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: Acme::Damn: 0 Attribute::Handlers: 0 Devel::Symdump: 0 File::Spec: 0 if: 0 IO::Socket: 1.18 List::MoreUtils: 0.15 Scalar::Util: 1.11 Storable: 0 Sys::SigAction: 0.11 Test::More: 0 Time::HiRes: 0 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.56 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 forks-0.34/ppport.h0100644000076500000240000022501711405345225012225 0ustar games#if 0 <<'SKIP'; #endif /* ---------------------------------------------------------------------- ppport.h -- Perl/Pollution/Portability Version 3.19 Automatically created by Devel::PPPort running under perl 5.008008. Version 3.x, Copyright (c) 2004-2009, Marcus Holland-Moritz. Version 2.x, Copyright (C) 2001, Paul Marquess. Version 1.x, Copyright (C) 1999, Kenneth Albanowski. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. ---------------------------------------------------------------------- SKIP if (@ARGV && $ARGV[0] eq '--unstrip') { eval { require Devel::PPPort }; $@ and die "Cannot require Devel::PPPort, please install.\n"; if (eval $Devel::PPPort::VERSION < 3.19) { die "ppport.h was originally generated with Devel::PPPort 3.19.\n" . "Your Devel::PPPort is only version $Devel::PPPort::VERSION.\n" . "Please install a newer version, or --unstrip will not work.\n"; } Devel::PPPort::WriteFile($0); exit 0; } print < #endif #if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) #include #endif #ifndef PERL_REVISION #define PERL_REVISION (5) #define PERL_VERSION PATCHLEVEL #define PERL_SUBVERSION SUBVERSION #endif #endif #define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) #define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION)) #if PERL_REVISION != 5 #error ppport.h only works with Perl version 5 #endif #ifndef dTHR #define dTHR dNOOP #endif #ifndef dTHX #define dTHX dNOOP #endif #ifndef dTHXa #define dTHXa(x) dNOOP #endif #ifndef pTHX #define pTHX void #endif #ifndef pTHX_ #define pTHX_ #endif #ifndef aTHX #define aTHX #endif #ifndef aTHX_ #define aTHX_ #endif #if (PERL_BCDVERSION < 0x5006000) #ifdef USE_THREADS #define aTHXR thr #define aTHXR_ thr, #else #define aTHXR #define aTHXR_ #endif #define dTHXR dTHR #else #define aTHXR aTHX #define aTHXR_ aTHX_ #define dTHXR dTHX #endif #ifndef dTHXoa #define dTHXoa(x) dTHXa(x) #endif #ifdef I_LIMITS #include #endif #ifndef PERL_UCHAR_MIN #define PERL_UCHAR_MIN ((unsigned char)0) #endif #ifndef PERL_UCHAR_MAX #ifdef UCHAR_MAX #define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) #else #ifdef MAXUCHAR #define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) #else #define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) #endif #endif #endif #ifndef PERL_USHORT_MIN #define PERL_USHORT_MIN ((unsigned short)0) #endif #ifndef PERL_USHORT_MAX #ifdef USHORT_MAX #define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) #else #ifdef MAXUSHORT #define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) #else #ifdef USHRT_MAX #define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) #else #define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) #endif #endif #endif #endif #ifndef PERL_SHORT_MAX #ifdef SHORT_MAX #define PERL_SHORT_MAX ((short)SHORT_MAX) #else #ifdef MAXSHORT #define PERL_SHORT_MAX ((short)MAXSHORT) #else #ifdef SHRT_MAX #define PERL_SHORT_MAX ((short)SHRT_MAX) #else #define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) #endif #endif #endif #endif #ifndef PERL_SHORT_MIN #ifdef SHORT_MIN #define PERL_SHORT_MIN ((short)SHORT_MIN) #else #ifdef MINSHORT #define PERL_SHORT_MIN ((short)MINSHORT) #else #ifdef SHRT_MIN #define PERL_SHORT_MIN ((short)SHRT_MIN) #else #define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) #endif #endif #endif #endif #ifndef PERL_UINT_MAX #ifdef UINT_MAX #define PERL_UINT_MAX ((unsigned int)UINT_MAX) #else #ifdef MAXUINT #define PERL_UINT_MAX ((unsigned int)MAXUINT) #else #define PERL_UINT_MAX (~(unsigned int)0) #endif #endif #endif #ifndef PERL_UINT_MIN #define PERL_UINT_MIN ((unsigned int)0) #endif #ifndef PERL_INT_MAX #ifdef INT_MAX #define PERL_INT_MAX ((int)INT_MAX) #else #ifdef MAXINT #define PERL_INT_MAX ((int)MAXINT) #else #define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) #endif #endif #endif #ifndef PERL_INT_MIN #ifdef INT_MIN #define PERL_INT_MIN ((int)INT_MIN) #else #ifdef MININT #define PERL_INT_MIN ((int)MININT) #else #define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) #endif #endif #endif #ifndef PERL_ULONG_MAX #ifdef ULONG_MAX #define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) #else #ifdef MAXULONG #define PERL_ULONG_MAX ((unsigned long)MAXULONG) #else #define PERL_ULONG_MAX (~(unsigned long)0) #endif #endif #endif #ifndef PERL_ULONG_MIN #define PERL_ULONG_MIN ((unsigned long)0L) #endif #ifndef PERL_LONG_MAX #ifdef LONG_MAX #define PERL_LONG_MAX ((long)LONG_MAX) #else #ifdef MAXLONG #define PERL_LONG_MAX ((long)MAXLONG) #else #define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) #endif #endif #endif #ifndef PERL_LONG_MIN #ifdef LONG_MIN #define PERL_LONG_MIN ((long)LONG_MIN) #else #ifdef MINLONG #define PERL_LONG_MIN ((long)MINLONG) #else #define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) #endif #endif #endif #if defined(HAS_QUAD) && (defined(convex) || defined(uts)) #ifndef PERL_UQUAD_MAX #ifdef ULONGLONG_MAX #define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) #else #ifdef MAXULONGLONG #define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) #else #define PERL_UQUAD_MAX (~(unsigned long long)0) #endif #endif #endif #ifndef PERL_UQUAD_MIN #define PERL_UQUAD_MIN ((unsigned long long)0L) #endif #ifndef PERL_QUAD_MAX #ifdef LONGLONG_MAX #define PERL_QUAD_MAX ((long long)LONGLONG_MAX) #else #ifdef MAXLONGLONG #define PERL_QUAD_MAX ((long long)MAXLONGLONG) #else #define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) #endif #endif #endif #ifndef PERL_QUAD_MIN #ifdef LONGLONG_MIN #define PERL_QUAD_MIN ((long long)LONGLONG_MIN) #else #ifdef MINLONGLONG #define PERL_QUAD_MIN ((long long)MINLONGLONG) #else #define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) #endif #endif #endif #endif #ifdef HAS_QUAD #ifdef cray #ifndef IVTYPE #define IVTYPE int #endif #ifndef IV_MIN #define IV_MIN PERL_INT_MIN #endif #ifndef IV_MAX #define IV_MAX PERL_INT_MAX #endif #ifndef UV_MIN #define UV_MIN PERL_UINT_MIN #endif #ifndef UV_MAX #define UV_MAX PERL_UINT_MAX #endif #ifdef INTSIZE #ifndef IVSIZE #define IVSIZE INTSIZE #endif #endif #else #if defined(convex) || defined(uts) #ifndef IVTYPE #define IVTYPE long long #endif #ifndef IV_MIN #define IV_MIN PERL_QUAD_MIN #endif #ifndef IV_MAX #define IV_MAX PERL_QUAD_MAX #endif #ifndef UV_MIN #define UV_MIN PERL_UQUAD_MIN #endif #ifndef UV_MAX #define UV_MAX PERL_UQUAD_MAX #endif #ifdef LONGLONGSIZE #ifndef IVSIZE #define IVSIZE LONGLONGSIZE #endif #endif #else #ifndef IVTYPE #define IVTYPE long #endif #ifndef IV_MIN #define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX #define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN #define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX #define UV_MAX PERL_ULONG_MAX #endif #ifdef LONGSIZE #ifndef IVSIZE #define IVSIZE LONGSIZE #endif #endif #endif #endif #ifndef IVSIZE #define IVSIZE 8 #endif #ifndef PERL_QUAD_MIN #define PERL_QUAD_MIN IV_MIN #endif #ifndef PERL_QUAD_MAX #define PERL_QUAD_MAX IV_MAX #endif #ifndef PERL_UQUAD_MIN #define PERL_UQUAD_MIN UV_MIN #endif #ifndef PERL_UQUAD_MAX #define PERL_UQUAD_MAX UV_MAX #endif #else #ifndef IVTYPE #define IVTYPE long #endif #ifndef IV_MIN #define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX #define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN #define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX #define UV_MAX PERL_ULONG_MAX #endif #endif #ifndef IVSIZE #ifdef LONGSIZE #define IVSIZE LONGSIZE #else #define IVSIZE 4 #endif #endif #ifndef UVTYPE #define UVTYPE unsigned IVTYPE #endif #ifndef UVSIZE #define UVSIZE IVSIZE #endif #ifndef sv_setuv #define sv_setuv(sv, uv) \ STMT_START { \ UV TeMpUv = uv; \ if (TeMpUv <= IV_MAX) \ sv_setiv(sv, TeMpUv); \ else \ sv_setnv(sv, (double)TeMpUv); \ } STMT_END #endif #ifndef newSVuv #define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) #endif #ifndef sv_2uv #define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) #endif #ifndef SvUVX #define SvUVX(sv) ((UV)SvIVX(sv)) #endif #ifndef SvUVXx #define SvUVXx(sv) SvUVX(sv) #endif #ifndef SvUV #define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) #endif #ifndef SvUVx #define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) #endif #ifndef sv_uv #define sv_uv(sv) SvUVx(sv) #endif #if !defined(SvUOK) && defined(SvIOK_UV) #define SvUOK(sv) SvIOK_UV(sv) #endif #ifndef XST_mUV #define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) #endif #ifndef XSRETURN_UV #define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END #endif #ifndef PUSHu #define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END #endif #ifndef XPUSHu #define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END #endif #ifdef HAS_MEMCMP #ifndef memNE #define memNE(s1,s2,l) (memcmp(s1,s2,l)) #endif #ifndef memEQ #define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) #endif #else #ifndef memNE #define memNE(s1,s2,l) (bcmp(s1,s2,l)) #endif #ifndef memEQ #define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) #endif #endif #ifndef MoveD #define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifndef CopyD #define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifdef HAS_MEMSET #ifndef ZeroD #define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) #endif #else #ifndef ZeroD #define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d) #endif #endif #ifndef PoisonWith #define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) #endif #ifndef PoisonNew #define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) #endif #ifndef PoisonFree #define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) #endif #ifndef Poison #define Poison(d,n,t) PoisonFree(d,n,t) #endif #ifndef Newx #define Newx(v,n,t) New(0,v,n,t) #endif #ifndef Newxc #define Newxc(v,n,t,c) Newc(0,v,n,t,c) #endif #ifndef Newxz #define Newxz(v,n,t) Newz(0,v,n,t) #endif #ifndef PERL_UNUSED_DECL #ifdef HASATTRIBUTE #if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) #define PERL_UNUSED_DECL #else #define PERL_UNUSED_DECL __attribute__((unused)) #endif #else #define PERL_UNUSED_DECL #endif #endif #ifndef PERL_UNUSED_ARG #if defined(lint) && defined(S_SPLINT_S) #include #define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) #else #define PERL_UNUSED_ARG(x) ((void)x) #endif #endif #ifndef PERL_UNUSED_VAR #define PERL_UNUSED_VAR(x) ((void)x) #endif #ifndef PERL_UNUSED_CONTEXT #ifdef USE_ITHREADS #define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) #else #define PERL_UNUSED_CONTEXT #endif #endif #ifndef NOOP #define NOOP (void)0 #endif #ifndef dNOOP #define dNOOP extern int Perl___notused PERL_UNUSED_DECL #endif #ifndef NVTYPE #if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) #define NVTYPE long double #else #define NVTYPE double #endif typedef NVTYPE NV; #endif #ifndef INT2PTR #if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) #define PTRV UV #define INT2PTR(any,d) (any)(d) #else #if PTRSIZE == LONGSIZE #define PTRV unsigned long #else #define PTRV unsigned #endif #define INT2PTR(any,d) (any)(PTRV)(d) #endif #endif #ifndef PTR2ul #if PTRSIZE == LONGSIZE #define PTR2ul(p) (unsigned long)(p) #else #define PTR2ul(p) INT2PTR(unsigned long,p) #endif #endif #ifndef PTR2nat #define PTR2nat(p) (PTRV)(p) #endif #ifndef NUM2PTR #define NUM2PTR(any,d) (any)PTR2nat(d) #endif #ifndef PTR2IV #define PTR2IV(p) INT2PTR(IV,p) #endif #ifndef PTR2UV #define PTR2UV(p) INT2PTR(UV,p) #endif #ifndef PTR2NV #define PTR2NV(p) NUM2PTR(NV,p) #endif #undef START_EXTERN_C #undef END_EXTERN_C #undef EXTERN_C #ifdef __cplusplus #define START_EXTERN_C extern "C" { #define END_EXTERN_C } #define EXTERN_C extern "C" #else #define START_EXTERN_C #define END_EXTERN_C #define EXTERN_C extern #endif #if defined(PERL_GCC_PEDANTIC) #ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN #define PERL_GCC_BRACE_GROUPS_FORBIDDEN #endif #endif #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) #ifndef PERL_USE_GCC_BRACE_GROUPS #define PERL_USE_GCC_BRACE_GROUPS #endif #endif #undef STMT_START #undef STMT_END #ifdef PERL_USE_GCC_BRACE_GROUPS #define STMT_START (void)( #define STMT_END ) #else #if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) #define STMT_START if (1) #define STMT_END else (void)0 #else #define STMT_START do #define STMT_END while (0) #endif #endif #ifndef boolSV #define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) #endif #ifndef DEFSV #define DEFSV GvSV(PL_defgv) #endif #ifndef SAVE_DEFSV #define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) #endif #ifndef DEFSV_set #define DEFSV_set(sv) (DEFSV = (sv)) #endif #ifndef AvFILLp #define AvFILLp AvFILL #endif #ifndef ERRSV #define ERRSV get_sv("@",FALSE) #endif #ifndef gv_stashpvn #define gv_stashpvn(str,len,create) gv_stashpv(str,create) #endif #ifndef get_cv #define get_cv perl_get_cv #endif #ifndef get_sv #define get_sv perl_get_sv #endif #ifndef get_av #define get_av perl_get_av #endif #ifndef get_hv #define get_hv perl_get_hv #endif #ifndef dUNDERBAR #define dUNDERBAR dNOOP #endif #ifndef UNDERBAR #define UNDERBAR DEFSV #endif #ifndef dAX #define dAX I32 ax = MARK - PL_stack_base + 1 #endif #ifndef dITEMS #define dITEMS I32 items = SP - MARK #endif #ifndef dXSTARG #define dXSTARG SV * targ = sv_newmortal() #endif #ifndef dAXMARK #define dAXMARK I32 ax = POPMARK; \ register SV ** const mark = PL_stack_base + ax++ #endif #ifndef XSprePUSH #define XSprePUSH (sp = PL_stack_base + ax - 1) #endif #if (PERL_BCDVERSION < 0x5005000) #undef XSRETURN #define XSRETURN(off) \ STMT_START { \ PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ return; \ } STMT_END #endif #ifndef XSPROTO #define XSPROTO(name) void name(pTHX_ CV* cv) #endif #ifndef SVfARG #define SVfARG(p) ((void*)(p)) #endif #ifndef PERL_ABS #define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) #endif #ifndef dVAR #define dVAR dNOOP #endif #ifndef SVf #define SVf "_" #endif #ifndef UTF8_MAXBYTES #define UTF8_MAXBYTES UTF8_MAXLEN #endif #ifndef CPERLscope #define CPERLscope(x) x #endif #ifndef PERL_HASH #define PERL_HASH(hash,str,len) \ STMT_START { \ const char *s_PeRlHaSh = str; \ I32 i_PeRlHaSh = len; \ U32 hash_PeRlHaSh = 0; \ while (i_PeRlHaSh--) \ hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ (hash) = hash_PeRlHaSh; \ } STMT_END #endif #ifndef PERLIO_FUNCS_DECL #ifdef PERLIO_FUNCS_CONST #define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs #define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) #else #define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs #define PERLIO_FUNCS_CAST(funcs) (funcs) #endif #endif #if (PERL_BCDVERSION < 0x5009003) #ifdef ARGSproto typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); #else typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); #endif typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); #endif #ifndef isPSXSPC #define isPSXSPC(c) (isSPACE(c) || (c) == '\v') #endif #ifndef isBLANK #define isBLANK(c) ((c) == ' ' || (c) == '\t') #endif #ifdef EBCDIC #ifndef isALNUMC #define isALNUMC(c) isalnum(c) #endif #ifndef isASCII #define isASCII(c) isascii(c) #endif #ifndef isCNTRL #define isCNTRL(c) iscntrl(c) #endif #ifndef isGRAPH #define isGRAPH(c) isgraph(c) #endif #ifndef isPRINT #define isPRINT(c) isprint(c) #endif #ifndef isPUNCT #define isPUNCT(c) ispunct(c) #endif #ifndef isXDIGIT #define isXDIGIT(c) isxdigit(c) #endif #else #if (PERL_BCDVERSION < 0x5010000) #undef isPRINT #endif #ifndef isALNUMC #define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) #endif #ifndef isASCII #define isASCII(c) ((c) <= 127) #endif #ifndef isCNTRL #define isCNTRL(c) ((c) < ' ' || (c) == 127) #endif #ifndef isGRAPH #define isGRAPH(c) (isALNUM(c) || isPUNCT(c)) #endif #ifndef isPRINT #define isPRINT(c) (((c) >= 32 && (c) < 127)) #endif #ifndef isPUNCT #define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) #endif #ifndef isXDIGIT #define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) #endif #endif #ifndef PERL_SIGNALS_UNSAFE_FLAG #define PERL_SIGNALS_UNSAFE_FLAG 0x0001 #if (PERL_BCDVERSION < 0x5008000) #define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG #else #define D_PPP_PERL_SIGNALS_INIT 0 #endif #if defined(NEED_PL_signals) static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #elif defined(NEED_PL_signals_GLOBAL) U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #else extern U32 DPPP_(my_PL_signals); #endif #define PL_signals DPPP_(my_PL_signals) #endif #if (PERL_BCDVERSION <= 0x5005005) #define PL_ppaddr ppaddr #define PL_no_modify no_modify #endif #if (PERL_BCDVERSION <= 0x5004005) #define PL_DBsignal DBsignal #define PL_DBsingle DBsingle #define PL_DBsub DBsub #define PL_DBtrace DBtrace #define PL_Sv Sv #define PL_bufend bufend #define PL_bufptr bufptr #define PL_compiling compiling #define PL_copline copline #define PL_curcop curcop #define PL_curstash curstash #define PL_debstash debstash #define PL_defgv defgv #define PL_diehook diehook #define PL_dirty dirty #define PL_dowarn dowarn #define PL_errgv errgv #define PL_error_count error_count #define PL_expect expect #define PL_hexdigit hexdigit #define PL_hints hints #define PL_in_my in_my #define PL_laststatval laststatval #define PL_lex_state lex_state #define PL_lex_stuff lex_stuff #define PL_linestr linestr #define PL_na na #define PL_perl_destruct_level perl_destruct_level #define PL_perldb perldb #define PL_rsfp_filters rsfp_filters #define PL_rsfp rsfp #define PL_stack_base stack_base #define PL_stack_sp stack_sp #define PL_statcache statcache #define PL_stdingv stdingv #define PL_sv_arenaroot sv_arenaroot #define PL_sv_no sv_no #define PL_sv_undef sv_undef #define PL_sv_yes sv_yes #define PL_tainted tainted #define PL_tainting tainting #define PL_tokenbuf tokenbuf #endif #if (PERL_BCDVERSION >= 0x5009005) #ifdef DPPP_PL_parser_NO_DUMMY #define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ (croak("panic: PL_parser == NULL in %s:%d", \ __FILE__, __LINE__), (yy_parser *) NULL))->var) #else #ifdef DPPP_PL_parser_NO_DUMMY_WARNING #define D_PPP_parser_dummy_warning(var) #else #define D_PPP_parser_dummy_warning(var) \ warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), #endif #define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) #if defined(NEED_PL_parser) static yy_parser DPPP_(dummy_PL_parser); #elif defined(NEED_PL_parser_GLOBAL) yy_parser DPPP_(dummy_PL_parser); #else extern yy_parser DPPP_(dummy_PL_parser); #endif #endif #define PL_expect D_PPP_my_PL_parser_var(expect) #define PL_copline D_PPP_my_PL_parser_var(copline) #define PL_rsfp D_PPP_my_PL_parser_var(rsfp) #define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) #define PL_linestr D_PPP_my_PL_parser_var(linestr) #define PL_bufptr D_PPP_my_PL_parser_var(bufptr) #define PL_bufend D_PPP_my_PL_parser_var(bufend) #define PL_lex_state D_PPP_my_PL_parser_var(lex_state) #define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) #define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) #define PL_in_my D_PPP_my_PL_parser_var(in_my) #define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash) #define PL_error_count D_PPP_my_PL_parser_var(error_count) #else #define PL_parser ((void *) 1) #endif #ifndef mPUSHs #define mPUSHs(s) PUSHs(sv_2mortal(s)) #endif #ifndef PUSHmortal #define PUSHmortal PUSHs(sv_newmortal()) #endif #ifndef mPUSHp #define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) #endif #ifndef mPUSHn #define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) #endif #ifndef mPUSHi #define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) #endif #ifndef mPUSHu #define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) #endif #ifndef mXPUSHs #define mXPUSHs(s) XPUSHs(sv_2mortal(s)) #endif #ifndef XPUSHmortal #define XPUSHmortal XPUSHs(sv_newmortal()) #endif #ifndef mXPUSHp #define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END #endif #ifndef mXPUSHn #define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END #endif #ifndef mXPUSHi #define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END #endif #ifndef mXPUSHu #define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END #endif #ifndef call_sv #define call_sv perl_call_sv #endif #ifndef call_pv #define call_pv perl_call_pv #endif #ifndef call_argv #define call_argv perl_call_argv #endif #ifndef call_method #define call_method perl_call_method #endif #ifndef eval_sv #define eval_sv perl_eval_sv #endif #ifndef PERL_LOADMOD_DENY #define PERL_LOADMOD_DENY 0x1 #endif #ifndef PERL_LOADMOD_NOIMPORT #define PERL_LOADMOD_NOIMPORT 0x2 #endif #ifndef PERL_LOADMOD_IMPORT_OPS #define PERL_LOADMOD_IMPORT_OPS 0x4 #endif #ifndef G_METHOD #define G_METHOD 64 #ifdef call_sv #undef call_sv #endif #if (PERL_BCDVERSION < 0x5006000) #define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) #else #define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) #endif #endif #ifndef eval_pv #if defined(NEED_eval_pv) static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); static #else extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); #endif #ifdef eval_pv #undef eval_pv #endif #define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) #define Perl_eval_pv DPPP_(my_eval_pv) #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error) { dSP; SV* sv = newSVpv(p, 0); PUSHMARK(sp); eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); SPAGAIN; sv = POPs; PUTBACK; if (croak_on_error && SvTRUE(GvSV(errgv))) croak(SvPVx(GvSV(errgv), na)); return sv; } #endif #endif #ifndef vload_module #if defined(NEED_vload_module) static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); static #else extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); #endif #ifdef vload_module #undef vload_module #endif #define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) #define Perl_vload_module DPPP_(my_vload_module) #if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) { dTHR; dVAR; OP *veop, *imop; OP * const modname = newSVOP(OP_CONST, 0, name); SvREADONLY_off(((SVOP*)modname)->op_sv); modname->op_private |= OPpCONST_BARE; if (ver) { veop = newSVOP(OP_CONST, 0, ver); } else veop = NULL; if (flags & PERL_LOADMOD_NOIMPORT) { imop = sawparens(newNULLLIST()); } else if (flags & PERL_LOADMOD_IMPORT_OPS) { imop = va_arg(*args, OP*); } else { SV *sv; imop = NULL; sv = va_arg(*args, SV*); while (sv) { imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); sv = va_arg(*args, SV*); } } { const line_t ocopline = PL_copline; COP * const ocurcop = PL_curcop; const int oexpect = PL_expect; #if (PERL_BCDVERSION >= 0x5004000) utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); #else utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), modname, imop); #endif PL_expect = oexpect; PL_copline = ocopline; PL_curcop = ocurcop; } } #endif #endif #ifndef load_module #if defined(NEED_load_module) static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); static #else extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); #endif #ifdef load_module #undef load_module #endif #define load_module DPPP_(my_load_module) #define Perl_load_module DPPP_(my_load_module) #if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) { va_list args; va_start(args, ver); vload_module(flags, name, ver, &args); va_end(args); } #endif #endif #ifndef newRV_inc #define newRV_inc(sv) newRV(sv) #endif #ifndef newRV_noinc #if defined(NEED_newRV_noinc) static SV * DPPP_(my_newRV_noinc)(SV *sv); static #else extern SV * DPPP_(my_newRV_noinc)(SV *sv); #endif #ifdef newRV_noinc #undef newRV_noinc #endif #define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) #define Perl_newRV_noinc DPPP_(my_newRV_noinc) #if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) SV * DPPP_(my_newRV_noinc)(SV *sv) { SV *rv = (SV *)newRV(sv); SvREFCNT_dec(sv); return rv; } #endif #endif #if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) #if defined(NEED_newCONSTSUB) static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); static #else extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); #endif #ifdef newCONSTSUB #undef newCONSTSUB #endif #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) #define D_PPP_PL_copline PL_copline void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) { U32 oldhints = PL_hints; HV *old_cop_stash = PL_curcop->cop_stash; HV *old_curstash = PL_curstash; line_t oldline = PL_curcop->cop_line; PL_curcop->cop_line = D_PPP_PL_copline; PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) PL_curstash = PL_curcop->cop_stash = stash; newSUB( #if (PERL_BCDVERSION < 0x5003022) start_subparse(), #elif (PERL_BCDVERSION == 0x5003022) start_subparse(0), #else start_subparse(FALSE, 0), #endif newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), newSVOP(OP_CONST, 0, &PL_sv_no), newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) ); PL_hints = oldhints; PL_curcop->cop_stash = old_cop_stash; PL_curstash = old_curstash; PL_curcop->cop_line = oldline; } #endif #endif #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) #ifndef START_MY_CXT #define START_MY_CXT #if (PERL_BCDVERSION < 0x5004068) #define dMY_CXT_SV \ SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) #else #define dMY_CXT_SV \ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ sizeof(MY_CXT_KEY)-1, TRUE) #endif #define dMY_CXT \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) #define MY_CXT_INIT \ dMY_CXT_SV; \ \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Zero(my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) #define MY_CXT (*my_cxtp) #define pMY_CXT my_cxt_t *my_cxtp #define pMY_CXT_ pMY_CXT, #define _pMY_CXT ,pMY_CXT #define aMY_CXT my_cxtp #define aMY_CXT_ aMY_CXT, #define _aMY_CXT ,aMY_CXT #endif #ifndef MY_CXT_CLONE #define MY_CXT_CLONE \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) #endif #else #ifndef START_MY_CXT #define START_MY_CXT static my_cxt_t my_cxt; #define dMY_CXT_SV dNOOP #define dMY_CXT dNOOP #define MY_CXT_INIT NOOP #define MY_CXT my_cxt #define pMY_CXT void #define pMY_CXT_ #define _pMY_CXT #define aMY_CXT #define aMY_CXT_ #define _aMY_CXT #endif #ifndef MY_CXT_CLONE #define MY_CXT_CLONE NOOP #endif #endif #ifndef IVdf #if IVSIZE == LONGSIZE #define IVdf "ld" #define UVuf "lu" #define UVof "lo" #define UVxf "lx" #define UVXf "lX" #else #if IVSIZE == INTSIZE #define IVdf "d" #define UVuf "u" #define UVof "o" #define UVxf "x" #define UVXf "X" #endif #endif #endif #ifndef NVef #if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) #define NVef PERL_PRIeldbl #define NVff PERL_PRIfldbl #define NVgf PERL_PRIgldbl #else #define NVef "e" #define NVff "f" #define NVgf "g" #endif #endif #ifndef SvREFCNT_inc #ifdef PERL_USE_GCC_BRACE_GROUPS #define SvREFCNT_inc(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (SvREFCNT(_sv))++; \ _sv; \ }) #else #define SvREFCNT_inc(sv) \ ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) #endif #endif #ifndef SvREFCNT_inc_simple #ifdef PERL_USE_GCC_BRACE_GROUPS #define SvREFCNT_inc_simple(sv) \ ({ \ if (sv) \ (SvREFCNT(sv))++; \ (SV *)(sv); \ }) #else #define SvREFCNT_inc_simple(sv) \ ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) #endif #endif #ifndef SvREFCNT_inc_NN #ifdef PERL_USE_GCC_BRACE_GROUPS #define SvREFCNT_inc_NN(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ SvREFCNT(_sv)++; \ _sv; \ }) #else #define SvREFCNT_inc_NN(sv) \ (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) #endif #endif #ifndef SvREFCNT_inc_void #ifdef PERL_USE_GCC_BRACE_GROUPS #define SvREFCNT_inc_void(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (void)(SvREFCNT(_sv)++); \ }) #else #define SvREFCNT_inc_void(sv) \ (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) #endif #endif #ifndef SvREFCNT_inc_simple_void #define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END #endif #ifndef SvREFCNT_inc_simple_NN #define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) #endif #ifndef SvREFCNT_inc_void_NN #define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef SvREFCNT_inc_simple_void_NN #define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef newSV_type #if defined(NEED_newSV_type) static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); static #else extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); #endif #ifdef newSV_type #undef newSV_type #endif #define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a) #define Perl_newSV_type DPPP_(my_newSV_type) #if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL) SV* DPPP_(my_newSV_type)(pTHX_ svtype const t) { SV* const sv = newSV(0); sv_upgrade(sv, t); return sv; } #endif #endif #if (PERL_BCDVERSION < 0x5006000) #define D_PPP_CONSTPV_ARG(x) ((char *) (x)) #else #define D_PPP_CONSTPV_ARG(x) (x) #endif #ifndef newSVpvn #define newSVpvn(data,len) ((data) \ ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ : newSV(0)) #endif #ifndef newSVpvn_utf8 #define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) #endif #ifndef SVf_UTF8 #define SVf_UTF8 0 #endif #ifndef newSVpvn_flags #if defined(NEED_newSVpvn_flags) static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); static #else extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); #endif #ifdef newSVpvn_flags #undef newSVpvn_flags #endif #define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) #define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) #if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) { SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); SvFLAGS(sv) |= (flags & SVf_UTF8); return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; } #endif #endif #if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) #define NEED_sv_2pv_flags #endif #if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) #define NEED_sv_2pv_flags_GLOBAL #endif #ifndef sv_2pv_nolen #define sv_2pv_nolen(sv) SvPV_nolen(sv) #endif #ifdef SvPVbyte #if (PERL_BCDVERSION < 0x5007000) #if defined(NEED_sv_2pvbyte) static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); static #else extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); #endif #ifdef sv_2pvbyte #undef sv_2pvbyte #endif #define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) #define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) #if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) { sv_utf8_downgrade(sv,0); return SvPV(sv,*lp); } #endif #undef SvPVbyte #define SvPVbyte(sv, lp) \ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) #endif #else #define SvPVbyte SvPV #define sv_2pvbyte sv_2pv #endif #ifndef sv_2pvbyte_nolen #define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) #endif #ifndef SV_IMMEDIATE_UNREF #define SV_IMMEDIATE_UNREF 0 #endif #ifndef SV_GMAGIC #define SV_GMAGIC 0 #endif #ifndef SV_COW_DROP_PV #define SV_COW_DROP_PV 0 #endif #ifndef SV_UTF8_NO_ENCODING #define SV_UTF8_NO_ENCODING 0 #endif #ifndef SV_NOSTEAL #define SV_NOSTEAL 0 #endif #ifndef SV_CONST_RETURN #define SV_CONST_RETURN 0 #endif #ifndef SV_MUTABLE_RETURN #define SV_MUTABLE_RETURN 0 #endif #ifndef SV_SMAGIC #define SV_SMAGIC 0 #endif #ifndef SV_HAS_TRAILING_NUL #define SV_HAS_TRAILING_NUL 0 #endif #ifndef SV_COW_SHARED_HASH_KEYS #define SV_COW_SHARED_HASH_KEYS 0 #endif #if (PERL_BCDVERSION < 0x5007002) #if defined(NEED_sv_2pv_flags) static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); static #else extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); #endif #ifdef sv_2pv_flags #undef sv_2pv_flags #endif #define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) #define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) #if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_2pv(sv, lp ? lp : &n_a); } #endif #if defined(NEED_sv_pvn_force_flags) static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); static #else extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); #endif #ifdef sv_pvn_force_flags #undef sv_pvn_force_flags #endif #define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) #define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) #if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_pvn_force(sv, lp ? lp : &n_a); } #endif #endif #if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) #define DPPP_SVPV_NOLEN_LP_ARG &PL_na #else #define DPPP_SVPV_NOLEN_LP_ARG 0 #endif #ifndef SvPV_const #define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_mutable #define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_flags #define SvPV_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) #endif #ifndef SvPV_flags_const #define SvPV_flags_const(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_const_nolen #define SvPV_flags_const_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : \ (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_mutable #define SvPV_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_force #define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nolen #define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) #endif #ifndef SvPV_force_mutable #define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nomg #define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) #endif #ifndef SvPV_force_nomg_nolen #define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) #endif #ifndef SvPV_force_flags #define SvPV_force_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) #endif #ifndef SvPV_force_flags_nolen #define SvPV_force_flags_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags)) #endif #ifndef SvPV_force_flags_mutable #define SvPV_force_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_nolen #define SvPV_nolen(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) #endif #ifndef SvPV_nolen_const #define SvPV_nolen_const(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) #endif #ifndef SvPV_nomg #define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) #endif #ifndef SvPV_nomg_const #define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) #endif #ifndef SvPV_nomg_const_nolen #define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) #endif #ifndef SvPV_renew #define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ SvPV_set((sv), (char *) saferealloc( \ (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ } STMT_END #endif #ifndef SvMAGIC_set #define SvMAGIC_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5009003) #ifndef SvPVX_const #define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) #endif #ifndef SvPVX_mutable #define SvPVX_mutable(sv) (0 + SvPVX(sv)) #endif #ifndef SvRV_set #define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END #endif #else #ifndef SvPVX_const #define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) #endif #ifndef SvPVX_mutable #define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) #endif #ifndef SvRV_set #define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ ((sv)->sv_u.svu_rv = (val)); } STMT_END #endif #endif #ifndef SvSTASH_set #define SvSTASH_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5004000) #ifndef SvUV_set #define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END #endif #else #ifndef SvUV_set #define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) #if defined(NEED_vnewSVpvf) static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); static #else extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); #endif #ifdef vnewSVpvf #undef vnewSVpvf #endif #define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) #define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) #if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) { register SV *sv = newSV(0); sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); return sv; } #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) #define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) #define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); #endif #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); #endif #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif #ifndef sv_catpvf_mg #ifdef PERL_IMPLICIT_CONTEXT #define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext #else #define sv_catpvf_mg Perl_sv_catpvf_mg #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) #define sv_vcatpvf_mg(sv, pat, args) \ STMT_START { \ sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); #endif #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); #endif #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif #ifndef sv_setpvf_mg #ifdef PERL_IMPLICIT_CONTEXT #define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext #else #define sv_setpvf_mg Perl_sv_setpvf_mg #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) #define sv_vsetpvf_mg(sv, pat, args) \ STMT_START { \ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif #ifndef newSVpvn_share #if defined(NEED_newSVpvn_share) static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); static #else extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); #endif #ifdef newSVpvn_share #undef newSVpvn_share #endif #define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) #define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) #if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) { SV *sv; if (len < 0) len = -len; if (!hash) PERL_HASH(hash, (char*) src, len); sv = newSVpvn((char *) src, len); sv_upgrade(sv, SVt_PVIV); SvIVX(sv) = hash; SvREADONLY_on(sv); SvPOK_on(sv); return sv; } #endif #endif #ifndef SvSHARED_HASH #define SvSHARED_HASH(sv) (0 + SvUVX(sv)) #endif #ifndef HvNAME_get #define HvNAME_get(hv) HvNAME(hv) #endif #ifndef HvNAMELEN_get #define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0) #endif #ifndef GvSVn #define GvSVn(gv) GvSV(gv) #endif #ifndef isGV_with_GP #define isGV_with_GP(gv) isGV(gv) #endif #ifndef WARN_ALL #define WARN_ALL 0 #endif #ifndef WARN_CLOSURE #define WARN_CLOSURE 1 #endif #ifndef WARN_DEPRECATED #define WARN_DEPRECATED 2 #endif #ifndef WARN_EXITING #define WARN_EXITING 3 #endif #ifndef WARN_GLOB #define WARN_GLOB 4 #endif #ifndef WARN_IO #define WARN_IO 5 #endif #ifndef WARN_CLOSED #define WARN_CLOSED 6 #endif #ifndef WARN_EXEC #define WARN_EXEC 7 #endif #ifndef WARN_LAYER #define WARN_LAYER 8 #endif #ifndef WARN_NEWLINE #define WARN_NEWLINE 9 #endif #ifndef WARN_PIPE #define WARN_PIPE 10 #endif #ifndef WARN_UNOPENED #define WARN_UNOPENED 11 #endif #ifndef WARN_MISC #define WARN_MISC 12 #endif #ifndef WARN_NUMERIC #define WARN_NUMERIC 13 #endif #ifndef WARN_ONCE #define WARN_ONCE 14 #endif #ifndef WARN_OVERFLOW #define WARN_OVERFLOW 15 #endif #ifndef WARN_PACK #define WARN_PACK 16 #endif #ifndef WARN_PORTABLE #define WARN_PORTABLE 17 #endif #ifndef WARN_RECURSION #define WARN_RECURSION 18 #endif #ifndef WARN_REDEFINE #define WARN_REDEFINE 19 #endif #ifndef WARN_REGEXP #define WARN_REGEXP 20 #endif #ifndef WARN_SEVERE #define WARN_SEVERE 21 #endif #ifndef WARN_DEBUGGING #define WARN_DEBUGGING 22 #endif #ifndef WARN_INPLACE #define WARN_INPLACE 23 #endif #ifndef WARN_INTERNAL #define WARN_INTERNAL 24 #endif #ifndef WARN_MALLOC #define WARN_MALLOC 25 #endif #ifndef WARN_SIGNAL #define WARN_SIGNAL 26 #endif #ifndef WARN_SUBSTR #define WARN_SUBSTR 27 #endif #ifndef WARN_SYNTAX #define WARN_SYNTAX 28 #endif #ifndef WARN_AMBIGUOUS #define WARN_AMBIGUOUS 29 #endif #ifndef WARN_BAREWORD #define WARN_BAREWORD 30 #endif #ifndef WARN_DIGIT #define WARN_DIGIT 31 #endif #ifndef WARN_PARENTHESIS #define WARN_PARENTHESIS 32 #endif #ifndef WARN_PRECEDENCE #define WARN_PRECEDENCE 33 #endif #ifndef WARN_PRINTF #define WARN_PRINTF 34 #endif #ifndef WARN_PROTOTYPE #define WARN_PROTOTYPE 35 #endif #ifndef WARN_QW #define WARN_QW 36 #endif #ifndef WARN_RESERVED #define WARN_RESERVED 37 #endif #ifndef WARN_SEMICOLON #define WARN_SEMICOLON 38 #endif #ifndef WARN_TAINT #define WARN_TAINT 39 #endif #ifndef WARN_THREADS #define WARN_THREADS 40 #endif #ifndef WARN_UNINITIALIZED #define WARN_UNINITIALIZED 41 #endif #ifndef WARN_UNPACK #define WARN_UNPACK 42 #endif #ifndef WARN_UNTIE #define WARN_UNTIE 43 #endif #ifndef WARN_UTF8 #define WARN_UTF8 44 #endif #ifndef WARN_VOID #define WARN_VOID 45 #endif #ifndef WARN_ASSERTIONS #define WARN_ASSERTIONS 46 #endif #ifndef packWARN #define packWARN(a) (a) #endif #ifndef ckWARN #ifdef G_WARN_ON #define ckWARN(a) (PL_dowarn & G_WARN_ON) #else #define ckWARN(a) PL_dowarn #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) #if defined(NEED_warner) static void DPPP_(my_warner)(U32 err, const char *pat, ...); static #else extern void DPPP_(my_warner)(U32 err, const char *pat, ...); #endif #define Perl_warner DPPP_(my_warner) #if defined(NEED_warner) || defined(NEED_warner_GLOBAL) void DPPP_(my_warner)(U32 err, const char *pat, ...) { SV *sv; va_list args; PERL_UNUSED_ARG(err); va_start(args, pat); sv = vnewSVpvf(pat, &args); va_end(args); sv_2mortal(sv); warn("%s", SvPV_nolen(sv)); } #define warner Perl_warner #define Perl_warner_nocontext Perl_warner #endif #endif #ifndef STR_WITH_LEN #define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) #endif #ifndef newSVpvs #define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) #endif #ifndef newSVpvs_flags #define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) #endif #ifndef sv_catpvs #define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) #endif #ifndef sv_setpvs #define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) #endif #ifndef hv_fetchs #define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) #endif #ifndef hv_stores #define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) #endif #ifndef gv_fetchpvn_flags #define gv_fetchpvn_flags(name, len, flags, svt) gv_fetchpv(name, flags, svt) #endif #ifndef gv_fetchpvs #define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt) #endif #ifndef gv_stashpvs #define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags) #endif #ifndef SvGETMAGIC #define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END #endif #ifndef PERL_MAGIC_sv #define PERL_MAGIC_sv '\0' #endif #ifndef PERL_MAGIC_overload #define PERL_MAGIC_overload 'A' #endif #ifndef PERL_MAGIC_overload_elem #define PERL_MAGIC_overload_elem 'a' #endif #ifndef PERL_MAGIC_overload_table #define PERL_MAGIC_overload_table 'c' #endif #ifndef PERL_MAGIC_bm #define PERL_MAGIC_bm 'B' #endif #ifndef PERL_MAGIC_regdata #define PERL_MAGIC_regdata 'D' #endif #ifndef PERL_MAGIC_regdatum #define PERL_MAGIC_regdatum 'd' #endif #ifndef PERL_MAGIC_env #define PERL_MAGIC_env 'E' #endif #ifndef PERL_MAGIC_envelem #define PERL_MAGIC_envelem 'e' #endif #ifndef PERL_MAGIC_fm #define PERL_MAGIC_fm 'f' #endif #ifndef PERL_MAGIC_regex_global #define PERL_MAGIC_regex_global 'g' #endif #ifndef PERL_MAGIC_isa #define PERL_MAGIC_isa 'I' #endif #ifndef PERL_MAGIC_isaelem #define PERL_MAGIC_isaelem 'i' #endif #ifndef PERL_MAGIC_nkeys #define PERL_MAGIC_nkeys 'k' #endif #ifndef PERL_MAGIC_dbfile #define PERL_MAGIC_dbfile 'L' #endif #ifndef PERL_MAGIC_dbline #define PERL_MAGIC_dbline 'l' #endif #ifndef PERL_MAGIC_mutex #define PERL_MAGIC_mutex 'm' #endif #ifndef PERL_MAGIC_shared #define PERL_MAGIC_shared 'N' #endif #ifndef PERL_MAGIC_shared_scalar #define PERL_MAGIC_shared_scalar 'n' #endif #ifndef PERL_MAGIC_collxfrm #define PERL_MAGIC_collxfrm 'o' #endif #ifndef PERL_MAGIC_tied #define PERL_MAGIC_tied 'P' #endif #ifndef PERL_MAGIC_tiedelem #define PERL_MAGIC_tiedelem 'p' #endif #ifndef PERL_MAGIC_tiedscalar #define PERL_MAGIC_tiedscalar 'q' #endif #ifndef PERL_MAGIC_qr #define PERL_MAGIC_qr 'r' #endif #ifndef PERL_MAGIC_sig #define PERL_MAGIC_sig 'S' #endif #ifndef PERL_MAGIC_sigelem #define PERL_MAGIC_sigelem 's' #endif #ifndef PERL_MAGIC_taint #define PERL_MAGIC_taint 't' #endif #ifndef PERL_MAGIC_uvar #define PERL_MAGIC_uvar 'U' #endif #ifndef PERL_MAGIC_uvar_elem #define PERL_MAGIC_uvar_elem 'u' #endif #ifndef PERL_MAGIC_vstring #define PERL_MAGIC_vstring 'V' #endif #ifndef PERL_MAGIC_vec #define PERL_MAGIC_vec 'v' #endif #ifndef PERL_MAGIC_utf8 #define PERL_MAGIC_utf8 'w' #endif #ifndef PERL_MAGIC_substr #define PERL_MAGIC_substr 'x' #endif #ifndef PERL_MAGIC_defelem #define PERL_MAGIC_defelem 'y' #endif #ifndef PERL_MAGIC_glob #define PERL_MAGIC_glob '*' #endif #ifndef PERL_MAGIC_arylen #define PERL_MAGIC_arylen '#' #endif #ifndef PERL_MAGIC_pos #define PERL_MAGIC_pos '.' #endif #ifndef PERL_MAGIC_backref #define PERL_MAGIC_backref '<' #endif #ifndef PERL_MAGIC_ext #define PERL_MAGIC_ext '~' #endif #ifndef sv_catpvn_nomg #define sv_catpvn_nomg sv_catpvn #endif #ifndef sv_catsv_nomg #define sv_catsv_nomg sv_catsv #endif #ifndef sv_setsv_nomg #define sv_setsv_nomg sv_setsv #endif #ifndef sv_pvn_nomg #define sv_pvn_nomg sv_pvn #endif #ifndef SvIV_nomg #define SvIV_nomg SvIV #endif #ifndef SvUV_nomg #define SvUV_nomg SvUV #endif #ifndef sv_catpv_mg #define sv_catpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catpvn_mg #define sv_catpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catsv_mg #define sv_catsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_catsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setiv_mg #define sv_setiv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setiv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setnv_mg #define sv_setnv_mg(sv, num) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setnv(TeMpSv,num); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpv_mg #define sv_setpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpvn_mg #define sv_setpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setsv_mg #define sv_setsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_setsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setuv_mg #define sv_setuv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setuv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_usepvn_mg #define sv_usepvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_usepvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef SvVSTRING_mg #define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) #endif #if (PERL_BCDVERSION < 0x5004000) #elif (PERL_BCDVERSION < 0x5008000) #define sv_magic_portable(sv, obj, how, name, namlen) \ STMT_START { \ SV *SvMp_sv = (sv); \ char *SvMp_name = (char *) (name); \ I32 SvMp_namlen = (namlen); \ if (SvMp_name && SvMp_namlen == 0) \ { \ MAGIC *mg; \ sv_magic(SvMp_sv, obj, how, 0, 0); \ mg = SvMAGIC(SvMp_sv); \ mg->mg_len = -42; \ mg->mg_ptr = SvMp_name; \ } \ else \ { \ sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ } \ } STMT_END #else #define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) #endif #ifdef USE_ITHREADS #ifndef CopFILE #define CopFILE(c) ((c)->cop_file) #endif #ifndef CopFILEGV #define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) #endif #ifndef CopFILE_set #define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) #endif #ifndef CopFILESV #define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) #endif #ifndef CopFILEAV #define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) #endif #ifndef CopSTASHPV #define CopSTASHPV(c) ((c)->cop_stashpv) #endif #ifndef CopSTASHPV_set #define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) #endif #ifndef CopSTASH #define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) #endif #ifndef CopSTASH_set #define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) #endif #ifndef CopSTASH_eq #define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ || (CopSTASHPV(c) && HvNAME(hv) \ && strEQ(CopSTASHPV(c), HvNAME(hv))))) #endif #else #ifndef CopFILEGV #define CopFILEGV(c) ((c)->cop_filegv) #endif #ifndef CopFILEGV_set #define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) #endif #ifndef CopFILE_set #define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) #endif #ifndef CopFILESV #define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) #endif #ifndef CopFILEAV #define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) #endif #ifndef CopFILE #define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) #endif #ifndef CopSTASH #define CopSTASH(c) ((c)->cop_stash) #endif #ifndef CopSTASH_set #define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) #endif #ifndef CopSTASHPV #define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) #endif #ifndef CopSTASHPV_set #define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) #endif #ifndef CopSTASH_eq #define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) #endif #endif #ifndef IN_PERL_COMPILETIME #define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) #endif #ifndef IN_LOCALE_RUNTIME #define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) #endif #ifndef IN_LOCALE_COMPILETIME #define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) #endif #ifndef IN_LOCALE #define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) #endif #ifndef IS_NUMBER_IN_UV #define IS_NUMBER_IN_UV 0x01 #endif #ifndef IS_NUMBER_GREATER_THAN_UV_MAX #define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 #endif #ifndef IS_NUMBER_NOT_INT #define IS_NUMBER_NOT_INT 0x04 #endif #ifndef IS_NUMBER_NEG #define IS_NUMBER_NEG 0x08 #endif #ifndef IS_NUMBER_INFINITY #define IS_NUMBER_INFINITY 0x10 #endif #ifndef IS_NUMBER_NAN #define IS_NUMBER_NAN 0x20 #endif #ifndef GROK_NUMERIC_RADIX #define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) #endif #ifndef PERL_SCAN_GREATER_THAN_UV_MAX #define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 #endif #ifndef PERL_SCAN_SILENT_ILLDIGIT #define PERL_SCAN_SILENT_ILLDIGIT 0x04 #endif #ifndef PERL_SCAN_ALLOW_UNDERSCORES #define PERL_SCAN_ALLOW_UNDERSCORES 0x01 #endif #ifndef PERL_SCAN_DISALLOW_PREFIX #define PERL_SCAN_DISALLOW_PREFIX 0x02 #endif #ifndef grok_numeric_radix #if defined(NEED_grok_numeric_radix) static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); static #else extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); #endif #ifdef grok_numeric_radix #undef grok_numeric_radix #endif #define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) #define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) bool DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) { #ifdef USE_LOCALE_NUMERIC #ifdef PL_numeric_radix_sv if (PL_numeric_radix_sv && IN_LOCALE) { STRLEN len; char* radix = SvPV(PL_numeric_radix_sv, len); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #else #include dTHR; struct lconv *lc = localeconv(); char *radix = lc->decimal_point; if (radix && IN_LOCALE) { STRLEN len = strlen(radix); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #endif #endif if (*sp < send && **sp == '.') { ++*sp; return TRUE; } return FALSE; } #endif #endif #ifndef grok_number #if defined(NEED_grok_number) static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); static #else extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); #endif #ifdef grok_number #undef grok_number #endif #define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) #define Perl_grok_number DPPP_(my_grok_number) #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) int DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) { const char *s = pv; const char *send = pv + len; const UV max_div_10 = UV_MAX / 10; const char max_mod_10 = UV_MAX % 10; int numtype = 0; int sawinf = 0; int sawnan = 0; while (s < send && isSPACE(*s)) s++; if (s == send) { return 0; } else if (*s == '-') { s++; numtype = IS_NUMBER_NEG; } else if (*s == '+') s++; if (s == send) return 0; if (isDIGIT(*s)) { UV value = *s - '0'; if (++s < send) { int digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; while (digit >= 0 && digit <= 9 && (value < max_div_10 || (value == max_div_10 && digit <= max_mod_10))) { value = value * 10 + digit; if (++s < send) digit = *s - '0'; else break; } if (digit >= 0 && digit <= 9 && (s < send)) { do { s++; } while (s < send && isDIGIT(*s)); numtype |= IS_NUMBER_GREATER_THAN_UV_MAX; goto skip_value; } } } } } } } } } } } } } } } } } } numtype |= IS_NUMBER_IN_UV; if (valuep) *valuep = value; skip_value: if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT; while (s < send && isDIGIT(*s)) s++; } } else if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); if (valuep) { *valuep = 0; } } else return 0; } else if (*s == 'I' || *s == 'i') { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; s++; if (s < send && (*s == 'I' || *s == 'i')) { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; s++; if (s == send || (*s != 'T' && *s != 't')) return 0; s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; s++; } sawinf = 1; } else if (*s == 'N' || *s == 'n') { s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; sawnan = 1; } else return 0; if (sawinf) { numtype &= IS_NUMBER_NEG; numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; } else if (sawnan) { numtype &= IS_NUMBER_NEG; numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; } else if (s < send) { if (*s == 'e' || *s == 'E') { numtype &= IS_NUMBER_NEG; numtype |= IS_NUMBER_NOT_INT; s++; if (s < send && (*s == '-' || *s == '+')) s++; if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); } else return 0; } } while (s < send && isSPACE(*s)) s++; if (s >= send) return numtype; if (len == 10 && memEQ(pv, "0 but true", 10)) { if (valuep) *valuep = 0; return IS_NUMBER_IN_UV; } return 0; } #endif #endif #ifndef grok_bin #if defined(NEED_grok_bin) static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_bin #undef grok_bin #endif #define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) #define Perl_grok_bin DPPP_(my_grok_bin) #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) UV DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_2 = UV_MAX / 2; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { if (len >= 1) { if (s[0] == 'b') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'b') { s+=2; len-=2; } } } for (; len-- && *s; s++) { char bit = *s; if (bit == '0' || bit == '1') { redo: if (!overflowed) { if (value <= max_div_2) { value = (value << 1) | (bit - '0'); continue; } warn("Integer overflow in binary number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 2.0; value_nv += (NV)(bit - '0'); continue; } if (bit == '_' && len && allow_underscores && (bit = s[1]) && (bit == '0' || bit == '1')) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal binary digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Binary number > 0b11111111111111111111111111111111 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_hex #if defined(NEED_grok_hex) static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_hex #undef grok_hex #endif #define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) #define Perl_grok_hex DPPP_(my_grok_hex) #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) UV DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_16 = UV_MAX / 16; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; const char *xdigit; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { if (len >= 1) { if (s[0] == 'x') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'x') { s+=2; len-=2; } } } for (; len-- && *s; s++) { xdigit = strchr((char *) PL_hexdigit, *s); if (xdigit) { redo: if (!overflowed) { if (value <= max_div_16) { value = (value << 4) | ((xdigit - PL_hexdigit) & 15); continue; } warn("Integer overflow in hexadecimal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 16.0; value_nv += (NV)((xdigit - PL_hexdigit) & 15); continue; } if (*s == '_' && len && allow_underscores && s[1] && (xdigit = strchr((char *) PL_hexdigit, s[1]))) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal hexadecimal digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Hexadecimal number > 0xffffffff non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_oct #if defined(NEED_grok_oct) static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_oct #undef grok_oct #endif #define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) #define Perl_grok_oct DPPP_(my_grok_oct) #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) UV DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_8 = UV_MAX / 8; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; for (; len-- && *s; s++) { int digit = *s - '0'; if (digit >= 0 && digit <= 7) { redo: if (!overflowed) { if (value <= max_div_8) { value = (value << 3) | digit; continue; } warn("Integer overflow in octal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 8.0; value_nv += (NV)digit; continue; } if (digit == ('_' - '0') && len && allow_underscores && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) { --len; ++s; goto redo; } if (digit == 8 || digit == 9) { if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal octal digit '%c' ignored", *s); } break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Octal number > 037777777777 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #if !defined(my_snprintf) #if defined(NEED_my_snprintf) static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); static #else extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); #endif #define my_snprintf DPPP_(my_my_snprintf) #define Perl_my_snprintf DPPP_(my_my_snprintf) #if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) int DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) { dTHX; int retval; va_list ap; va_start(ap, format); #ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, ap); #else retval = vsprintf(buffer, format, ap); #endif va_end(ap); if (retval < 0 || (len > 0 && (Size_t)retval >= len)) Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); return retval; } #endif #endif #if !defined(my_sprintf) #if defined(NEED_my_sprintf) static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); static #else extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); #endif #define my_sprintf DPPP_(my_my_sprintf) #define Perl_my_sprintf DPPP_(my_my_sprintf) #if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) int DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...) { va_list args; va_start(args, pat); vsprintf(buffer, pat, args); va_end(args); return strlen(buffer); } #endif #endif #ifdef NO_XSLOCKS #ifdef dJMPENV #define dXCPT dJMPENV; int rEtV = 0 #define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) #define XCPT_TRY_END JMPENV_POP; #define XCPT_CATCH if (rEtV != 0) #define XCPT_RETHROW JMPENV_JUMP(rEtV) #else #define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 #define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) #define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); #define XCPT_CATCH if (rEtV != 0) #define XCPT_RETHROW Siglongjmp(top_env, rEtV) #endif #endif #if !defined(my_strlcat) #if defined(NEED_my_strlcat) static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); #endif #define my_strlcat DPPP_(my_my_strlcat) #define Perl_my_strlcat DPPP_(my_my_strlcat) #if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) Size_t DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) { Size_t used, length, copy; used = strlen(dst); length = strlen(src); if (size > 0 && used < size - 1) { copy = (length >= size - used) ? size - used - 1 : length; memcpy(dst + used, src, copy); dst[used + copy] = '\0'; } return used + length; } #endif #endif #if !defined(my_strlcpy) #if defined(NEED_my_strlcpy) static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); #endif #define my_strlcpy DPPP_(my_my_strlcpy) #define Perl_my_strlcpy DPPP_(my_my_strlcpy) #if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) Size_t DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) { Size_t length, copy; length = strlen(src); if (size > 0) { copy = (length >= size) ? size - 1 : length; memcpy(dst, src, copy); dst[copy] = '\0'; } return length; } #endif #endif #ifndef PERL_PV_ESCAPE_QUOTE #define PERL_PV_ESCAPE_QUOTE 0x0001 #endif #ifndef PERL_PV_PRETTY_QUOTE #define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE #endif #ifndef PERL_PV_PRETTY_ELLIPSES #define PERL_PV_PRETTY_ELLIPSES 0x0002 #endif #ifndef PERL_PV_PRETTY_LTGT #define PERL_PV_PRETTY_LTGT 0x0004 #endif #ifndef PERL_PV_ESCAPE_FIRSTCHAR #define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 #endif #ifndef PERL_PV_ESCAPE_UNI #define PERL_PV_ESCAPE_UNI 0x0100 #endif #ifndef PERL_PV_ESCAPE_UNI_DETECT #define PERL_PV_ESCAPE_UNI_DETECT 0x0200 #endif #ifndef PERL_PV_ESCAPE_ALL #define PERL_PV_ESCAPE_ALL 0x1000 #endif #ifndef PERL_PV_ESCAPE_NOBACKSLASH #define PERL_PV_ESCAPE_NOBACKSLASH 0x2000 #endif #ifndef PERL_PV_ESCAPE_NOCLEAR #define PERL_PV_ESCAPE_NOCLEAR 0x4000 #endif #ifndef PERL_PV_ESCAPE_RE #define PERL_PV_ESCAPE_RE 0x8000 #endif #ifndef PERL_PV_PRETTY_NOCLEAR #define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR #endif #ifndef PERL_PV_PRETTY_DUMP #define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE #endif #ifndef PERL_PV_PRETTY_REGPROP #define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE #endif #ifndef pv_escape #if defined(NEED_pv_escape) static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); static #else extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); #endif #ifdef pv_escape #undef pv_escape #endif #define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f) #define Perl_pv_escape DPPP_(my_pv_escape) #if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) char * DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags) { const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\'; const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc; char octbuf[32] = "%123456789ABCDF"; STRLEN wrote = 0; STRLEN chsize = 0; STRLEN readsize = 1; #if defined(is_utf8_string) && defined(utf8_to_uvchr) bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0; #endif const char *pv = str; const char * const end = pv + count; octbuf[0] = esc; if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) sv_setpvs(dsv, ""); #if defined(is_utf8_string) && defined(utf8_to_uvchr) if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) isuni = 1; #endif for (; pv < end && (!max || wrote < max) ; pv += readsize) { const UV u = #if defined(is_utf8_string) && defined(utf8_to_uvchr) isuni ? utf8_to_uvchr((U8*)pv, &readsize) : #endif (U8)*pv; const U8 c = (U8)u & 0xFF; if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) { if (flags & PERL_PV_ESCAPE_FIRSTCHAR) chsize = my_snprintf(octbuf, sizeof octbuf, "%"UVxf, u); else chsize = my_snprintf(octbuf, sizeof octbuf, "%cx{%"UVxf"}", esc, u); } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { chsize = 1; } else { if (c == dq || c == esc || !isPRINT(c)) { chsize = 2; switch (c) { case '\\' : case '%' : if (c == esc) octbuf[1] = esc; else chsize = 1; break; case '\v' : octbuf[1] = 'v'; break; case '\t' : octbuf[1] = 't'; break; case '\r' : octbuf[1] = 'r'; break; case '\n' : octbuf[1] = 'n'; break; case '\f' : octbuf[1] = 'f'; break; case '"' : if (dq == '"') octbuf[1] = '"'; else chsize = 1; break; default: chsize = my_snprintf(octbuf, sizeof octbuf, pv < end && isDIGIT((U8)*(pv+readsize)) ? "%c%03o" : "%c%o", esc, c); } } else { chsize = 1; } } if (max && wrote + chsize > max) { break; } else if (chsize > 1) { sv_catpvn(dsv, octbuf, chsize); wrote += chsize; } else { char tmp[2]; my_snprintf(tmp, sizeof tmp, "%c", c); sv_catpvn(dsv, tmp, 1); wrote++; } if (flags & PERL_PV_ESCAPE_FIRSTCHAR) break; } if (escaped != NULL) *escaped= pv - str; return SvPVX(dsv); } #endif #endif #ifndef pv_pretty #if defined(NEED_pv_pretty) static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); static #else extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); #endif #ifdef pv_pretty #undef pv_pretty #endif #define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g) #define Perl_pv_pretty DPPP_(my_pv_pretty) #if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) char * DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags) { const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; STRLEN escaped; if (!(flags & PERL_PV_PRETTY_NOCLEAR)) sv_setpvs(dsv, ""); if (dq == '"') sv_catpvs(dsv, "\""); else if (flags & PERL_PV_PRETTY_LTGT) sv_catpvs(dsv, "<"); if (start_color != NULL) sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color)); pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR); if (end_color != NULL) sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color)); if (dq == '"') sv_catpvs(dsv, "\""); else if (flags & PERL_PV_PRETTY_LTGT) sv_catpvs(dsv, ">"); if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count) sv_catpvs(dsv, "..."); return SvPVX(dsv); } #endif #endif #ifndef pv_display #if defined(NEED_pv_display) static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); static #else extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); #endif #ifdef pv_display #undef pv_display #endif #define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e) #define Perl_pv_display DPPP_(my_pv_display) #if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) char * DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) { pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); if (len > cur && pv[cur] == '\0') sv_catpvs(dsv, "\\0"); return SvPVX(dsv); } #endif #endif #endif forks-0.34/README0100755000076500000240000000231711405321023011375 0ustar gamesREADME for forks Version: 0.34 The forks.pm module is a drop-in replacement for threads.pm. It has the same syntax as the threads.pm module (it even takes over its namespace) but has some significant differences: - you do _not_ need a special (threaded) version of Perl - it is _much_ more economic with memory usage on OS's that support COW - it is more efficient in the startup of threads - it is slightly less efficient in the stopping of threads - it is less efficient in inter-thread communication If for nothing else, it allows you to use the Perl threading model in non-threaded Perl builds and in older versions of Perl (5.6.0 and higher are supported). Copyright (c) 2005-2008 Eric Rybski , 2002-2004 Elizabeth Mattijsen . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Required Modules: Acme::Damn (any) Attribute::Handlers (any) Devel::Symdump (any) File::Spec (any) if (any) IO::Socket (1.18) List::MoreUtils (0.15) Scalar::Util (1.11) Storable (any) Sys::SigAction (0.11) Test::More (any) Time::HiRes (any) The build is standard: perl Makefile.PL make make test make install forks-0.34/SIGNATURE0100755000076500000240000000550611405351366012021 0ustar gamesThis file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.55. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 SHA1 caf1c6cc98552b9d6d7fc024f3bcd3019497d5bd CHANGELOG SHA1 455b7ebe2265a00e97f133c8cd7ebf56148a573d CREDITS SHA1 3b891564aac2c35b5016ba3c6a5d0dfa67b78a62 MANIFEST SHA1 0a40de91b5f4169eef3ff3ef456a40b79d056e78 MANIFEST.skip SHA1 e65dfda52c048de13ac9f1c051cc3cbe585e8402 META.yml SHA1 24f37b818f36c8c93acf447c05dbb3804a9368ae Makefile.PL SHA1 e75a558d750f60a93c86932192fe982b0d410281 README SHA1 a4ab922a5133b93496f3e5f037b7f9b4684b7555 TODO SHA1 b8554457d862188bf4bce3639881d99617bc4529 VERSION SHA1 1c3548011fb1c9210eff34e2ab563e3d42059f29 forks.xs SHA1 a77f83a63b52a8fba82b6a321c5796a2b0e085c6 lib/forks.pm SHA1 5652c39f2420041f153dfab66fc4a3fc133a025f lib/forks/Devel/Symdump.pm SHA1 cd37d8f45b342580bbc71e3fae23f6e19422a1f0 lib/forks/shared.pm SHA1 bf8c9cdbe2db94440679408334384f0e37eafb16 lib/forks/shared/attributes.pm SHA1 2a5fb60f3e373fcb7bd3b0fa64c4627a5476e44b lib/forks/shared/global_filter.pm SHA1 0f5cb2beb12425351fd25a41ac3f3ba4eeba8b9b lib/forks/signals.pm SHA1 69323faf9b45991bfa344985ac1740ab0a5808c3 lib/threads/shared/array.pm SHA1 7612ccf657d6b8b5c2654210eb3b252d2ef9989a lib/threads/shared/handle.pm SHA1 5f98eb1924251406f2491c71c5e275688963f541 lib/threads/shared/hash.pm SHA1 3425ecf491a0c2b66b6785d0158ecd819cb1397d lib/threads/shared/scalar.pm SHA1 c0911c487a42e39c8541d2db1ddd5fd74c7c1986 ppport.h SHA1 f22bda39f483db8ddaafd61935c6723d4087a778 t/forks00-requirements.t SHA1 e0b161c71a2dba88fa7827c54ab597bf29ba2cdb t/forks00-sigtrap.t SHA1 aa7a677571cc9789653d489bc7cab8fbc091773d t/forks01.t SHA1 dc739710ac9c97c36f8e2cb77ae5af4aee2e8447 t/forks02.t SHA1 0f74478dda08dbd57a29bb46ef5a95cdf6d864eb t/forks03.t SHA1 2863b14f575b3415ac7b415ad77a8a7ed5cb9143 t/forks04.t SHA1 5c172556a690f58812039b10a243376ec2b9d6e3 t/forks05.t SHA1 50af07b5275498fd708b4fb2d0de5e28062b33fd t/forks06.t SHA1 f8dd4f7c16f7ce96cde23f1953737468fa6bad7f t/forks07.t SHA1 4a5951b2c10bfd35e3281c07d4101fbe27779d02 t/forks08.t SHA1 b073b28bc806f47dabe93d69dd7e47dc7fe5ee6d t/forks09.t SHA1 84f14953836fd57500007907d3a30e9813fdfca3 t/forks10.t SHA1 d45ee162070db10b691958fa140d8fc297bd3d90 t/forks20.t SHA1 fc5734f9c393dcc9f12c87df4bf9362e88a800ad t/forks99.t -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.8 (Darwin) iEYEARECAAYFAkwV0vQACgkQQwn7DcpJEO610gCfaCQkK6q7fn4BX61UnYlNVAhi IlcAn2jpfXo09widnviXvEBpf4Qxyxv1 =3geb -----END PGP SIGNATURE----- forks-0.34/t/0040755000076500000240000000000011405353607010772 5ustar gamesforks-0.34/t/forks00-requirements.t0100644000076500000240000000165411405343262015163 0ustar games#!/usr/local/bin/perl -w BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; @INC = '../lib'; } elsif (!grep /blib/, @INC) { chdir 't' if -d 't'; unshift @INC, ('../blib/lib', '../blib/arch'); } } BEGIN {delete $ENV{THREADS_DEBUG}} # no debugging during testing! use Test::More tests => 7; use Scalar::Util; use File::Spec; use Acme::Damn (); use Storable (); use List::MoreUtils; use Sys::SigAction; ok(!(grep { /set_prototype/ } @Scalar::Util::EXPORT_FAIL), "Scalar::Util appears to have been compiled without XS features: set_prototype. Try rebuilding Scalar::Util package with `perl Makefile.PL -xs`"); can_ok( 'Scalar::Util',qw(set_prototype reftype blessed refaddr weaken) ); can_ok( 'File::Spec',qw(tmpdir) ); can_ok( 'Acme::Damn',qw(damn) ); can_ok( 'Storable',qw(freeze thaw) ); can_ok( 'List::MoreUtils',qw(firstidx minmax uniq) ); can_ok( 'Sys::SigAction', qw(set_sig_handler) ); forks-0.34/t/forks00-sigtrap.t0100644000076500000240000000356010657625470014123 0ustar games#!/usr/local/bin/perl -w BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; @INC = '../lib'; } elsif (!grep /blib/, @INC) { chdir 't' if -d 't'; unshift @INC, ('../blib/lib', '../blib/arch'); } } BEGIN {delete $ENV{THREADS_DEBUG}} # no debugging during testing! use forks::signals; use Test::More tests => 9; my $g = ''; my $g_cnt = 0; my $g_cnt_chk = 0; my $g_myhup_cnt = 0; my $g_myhup_cnt_chk = 0; my $ndef_hup = sub { $g = 'nhup'; $g_cnt++ }; my $def_hup = sub { $g = 'hup'; $g_cnt++ }; import forks::signals ifndef => { HUP => $ndef_hup }, ifdef => { HUP => $def_hup }; $SIG{HUP} = undef; $g_cnt_chk++; kill('SIGHUP', $$); is( $g,'nhup','Check that not defined HUP signal handler was triggered' ); $SIG{HUP} = 'DEFAULT'; $g_cnt_chk++; kill('SIGHUP', $$); is( $g,'nhup','Check that not defined HUP signal handler was triggered' ); $SIG{HUP} = 1; $g_cnt_chk++; kill('SIGHUP', $$); is( $g,'hup','Check that defined HUP signal handler was triggered' ); $SIG{HUP} = sub { 1 }; $g_cnt_chk++; kill('SIGHUP', $$); is( $g,'hup','Check that defined HUP signal handler was triggered' ); my $def_myhup = sub { $g = 'myhup'; $g_myhup_cnt++ }; $SIG{HUP} = $def_myhup; $g_cnt_chk++; $g_myhup_cnt_chk++; kill('SIGHUP', $$); is( $g,'myhup','Check that defined HUP signal handler was triggered' ); $SIG{HUP} = $def_myhup; $g_cnt_chk++; $g_myhup_cnt_chk++; kill('SIGHUP', $$); is( $g,'myhup','Check that defined HUP signal handler was triggered' ); $SIG{HUP} = undef; $SIG{HUP} = $def_myhup; $SIG{HUP} = $def_myhup; $g_cnt_chk++; $g_myhup_cnt_chk++; kill('SIGHUP', $$); is( $g,'myhup','Check that defined HUP signal handler was triggered' ); $SIG{HUP} = 'IGNORE'; kill('SIGHUP', $$); is( $g_cnt,$g_cnt_chk,'Check that all expected signals were handled' ); is( $g_myhup_cnt,$g_myhup_cnt_chk,'Verify no internal signal recursion occured' ); 1; forks-0.34/t/forks01.t0100755000076500000240000005354211155716670012462 0ustar games#!/usr/local/bin/perl -w BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; @INC = '../lib'; } elsif (!grep /blib/, @INC) { chdir 't' if -d 't'; unshift @INC, ('../blib/lib', '../blib/arch'); } } BEGIN {delete $ENV{THREADS_DEBUG}} # no debugging during testing! use forks; # must be done _before_ Test::More which loads real threads.pm use forks::shared; diag( <new->reset; } } # Patch Test::Builder to add fork-thread awareness { no warnings 'redefine'; my $_sanity_check_old = \&Test::Builder::_sanity_check; *Test::Builder::_sanity_check = sub { my $self = $_[0]; # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. if( $self->{Original_Pid} != $$ ) { return; } $_sanity_check_old->(@_); }; } use Test::More tests => 151; use strict; use warnings; can_ok( 'threads',qw( async create detach equal stringify import isthread join list new self tid is_running is_joinable is_detached is_deadlocked _handle get_stack_size set_stack_size wantarray ) ); can_ok( 'threads::shared',qw( cond_broadcast cond_signal cond_wait cond_timedwait lock share is_shared bless TIEARRAY TIEHANDLE TIEHASH TIESCALAR ) ); is( system("echo"),0, 'check that CORE::system still returns correct exit values' ); unless (my $pid = fork) { threads->isthread if defined($pid); threads->exit; } sleep 3; # make sure fork above has started to ensure tid's are in sync my $test_lock : shared; my $t1 = threads->new( sub { threads->tid } ); ok( $t1,'check whether we can start a thread with new()' ); cmp_ok( $t1->_handle, '>', 0 ,'check if we can get address of object' ); cmp_ok( threads->_handle, '>', 0 ,'check if we can get address of object' ); my $t2 = threads->create( sub { threads->tid } ); ok( $t2,'check whether we can start a thread with create()' ); my $t3 = async( sub { threads->object( threads->tid )->tid } ); ok( $t3,'check whether we can start a thread with async()' ); my %tid; $tid{$_->tid} = undef foreach threads->list; my $thr_cnt = threads->list; cmp_ok($thr_cnt, '==', 3, 'check that count of threads is correct'); is( join('',sort keys %tid),'234','check tids of all threads' ); ok($t1 == threads->object(2),'check that == works on threads objects'); ok($t1 != threads->object(3),'check that != works on threads objects'); is( $t3->join,'4','check return value thread 3' ); is( $t2->join,'3','check return value thread 2' ); is( $t1->join,'2','check return value thread 1' ); #== error ========================================================== { no warnings 'threads'; $t1 = threads->new( sub { die 'Thread called die.' } ); $t2 = threads->new( sub { die bless({status => 'die'}, 'somepkg') } ); } $t1->join(); like ( $t1->error,qr#^Thread called die. at t/forks01.t#,'check that thread returned expected error' ); $t2->join(); my $err = $t2->error; is ( ref($err),'somepkg','check that thread returned expected error object' ); is ( eval{$err->{status}},'die','check that thread error object is valid' ); #== exit =========================================================== $t1 = threads->new( sub { threads->exit() } ); $t1->join(); ok(1, 'check that only one thread exited'); $t1 = threads->new( {'exit' => 'thread_only'}, sub { exit() } ); $t1->join(); ok(1, 'check that only one thread exited'); $t1 = threads->new( sub { threads->set_thread_exit_only(1); exit() } ); $t1->join(); ok(1, 'check that only one thread exited'); $t1 = threads->new( sub { sleep 2; exit() } ); $t1->set_thread_exit_only(1); $t1->join(); ok(1, 'check that only one thread exited'); $t1 = threads->new( sub { import threads 'exit' => 'threads_only'; exit(); } ); $t1->join(); ok(1, 'check that only one thread exited'); #== SCALAR ========================================================= my $scalar = 10; share( $scalar ); share( $scalar ); #tests that we quietly support re-sharing a shared variable ok(is_shared( $scalar ), 'check if variable is_shared' ); my $tied = tied( $scalar ); isa_ok( $tied,'threads::shared', 'check tied object type' ); cmp_ok( $scalar,'==',10, 'check scalar numerical fetch' ); $scalar++; cmp_ok( $scalar,'==',11, 'check scalar increment' ); $scalar = 'Apenootjes'; is( $scalar,'Apenootjes', 'check scalar fetch' ); threads->new( sub {$scalar = 'from thread'} )->join; is( $scalar,'from thread', 'check scalar fetch' ); #== ARRAY ========================================================== my @array = qw(a b c); share( @array ); $tied = tied( @array ); isa_ok( $tied,'threads::shared', 'check tied object type' ); is( join('',@array),'abc', 'check array fetch' ); push( @array,qw(d e f) ); is( join('',@array),'abcdef', 'check array fetch' ); threads->new( sub {push( @array,qw(g h i) )} )->join; is( join('',@array),'abcdefghi', 'check array fetch' ); shift( @array ); is( join('',@array),'bcdefghi', 'check array fetch' ); unshift( @array,'a' ); is( join('',@array),'abcdefghi', 'check array fetch' ); pop( @array ); is( join('',@array),'abcdefgh', 'check array fetch' ); push( @array,'i' ); is( join('',@array),'abcdefghi', 'check array fetch' ); splice( @array,3,3 ); is( join('',@array),'abcghi', 'check array fetch' ); splice( @array,3,0,qw(d e f) ); is( join('',@array),'abcdefghi', 'check array fetch' ); splice( @array,0,3,qw(d e f) ); is( join('',@array),'defdefghi', 'check array fetch' ); delete( $array[0] ); is( join('',map {$_ || ''} @array),'efdefghi', 'check array fetch' ); @array = qw(a b c d e f g h i); is( join('',@array),'abcdefghi', 'check array fetch' ); cmp_ok( $#array,'==',8, 'check size' ); ok( exists( $array[8] ), 'check whether array element exists' ); ok( !exists( $array[9] ), 'check whether array element exists' ); $#array = 10; cmp_ok( scalar(@array),'==',11, 'check number of elements' ); is( join('',map {$_ || ''} @array),'abcdefghi', 'check array fetch' ); ok( !exists( $array[10] ), 'check whether array element exists' ); $array[10] = undef; ok( exists( $array[10] ), 'check whether array element exists' ); ok( !exists( $array[11] ), 'check whether array element exists' ); ok( !defined( $array[10] ), 'check whether array element defined' ); ok( !defined( $array[11] ), 'check whether array element defined' ); cmp_ok( scalar(@array),'==',11, 'check number of elements' ); @array = (); cmp_ok( scalar(@array),'==',0, 'check number of elements' ); is( join('',@array),'', 'check array fetch' ); @array = (); my $shared_scalar : shared = 'test'; push @array, $shared_scalar; is($array[0], 'test', 'push with a shared variable works'); #== HASH =========================================================== my %hash = (a => 'A'); share( %hash ); $tied = tied( %hash ); isa_ok( $tied,'threads::shared', 'check tied object type' ); is( $hash{'a'},'A', 'check hash fetch' ); $hash{'b'} = 'B'; is( $hash{'b'},'B', 'check hash fetch' ); is( join('',sort keys %hash),'ab', 'check hash keys' ); ok( !exists( $hash{'c'} ), 'check existence of key' ); threads->new( sub { $hash{'c'} = 'C' } )->join; ok( exists( $hash{'c'} ), 'check existence of key' ); is( $hash{'c'},'C', 'check hash fetch' ); is( join('',sort keys %hash),'abc', 'check hash keys' ); my %otherhash = %hash; is( join('',sort keys %otherhash),'abc','check hash keys' ); my @list; while (my ($key,$value) = each %hash) { push( @list,$key,$value ) } is( join('',sort @list),'ABCabc', 'check all eaches' ); delete( $hash{'b'} ); is( join('',sort keys %hash),'ac', 'check hash keys' ); %hash = (); cmp_ok( scalar(keys %hash),'==',0, 'check number of elements' ); is( join('',keys %hash),'', 'check hash fetch' ); #== errors ========================================================= my $foo; eval {lock $foo}; like( $@,qr#^lock can only be used on shared values#,'check unshared var' ); my $bar : shared; eval {cond_wait $bar}; like( $@,qr#^You need a lock before you can cond_wait#,'check unlocked var' ); eval {cond_timedwait $bar, time() + 5}; like( $@,qr#^You need a lock before you can cond_timedwait#,'check unlocked var' ); eval {lock $bar}; is( $@,'','check locking shared var' ); eval {lock $bar; cond_signal $bar}; is( $@,'','check locking and signalling shared var' ); my %foo : shared; eval {$foo{1}{foo}='a'}; like( $@,qr#^Invalid value for shared scalar#,'check store disallowed for non-shared ref' ); #== detach and join errors ========================================= { my ($t1, $t2); $t1 = threads->new(sub {}); $t1->detach(); eval { $t1->detach(); }; like( $@,qr#^Thread already detached#,'check die on detach detached' ); $t1 = threads->new(sub { sleep 3; }); $t2 = threads->new(sub { $t1->detach(); }); sleep 2; eval { $t1->join(); }; like( $@,qr#^Cannot join a detached thread#,'check die on join detached' ); $t2->join; $t1 = threads->new(sub { sleep 3; }); $t2 = threads->new(sub { $t1->join(); }); sleep 2; eval { $t1->join(); }; like( $@,qr#^Thread already joined#,'check die on join joined' ); $t2->join; # TODO: Unable to trigger this case yet (forks-specific cases, only in very specific circumstances) # $t1 = threads->new(sub {}); # $t2 = threads->new(sub { $t1->join(); }); # sleep 2; # eval { $t1->join(); }; # like( $@,qr#^Cannot join a detached or already joined thread#,'check die on join joined' ); # $t2->join; } #== fixed bugs ===================================================== my $zoo : shared; my $thread = threads->new( sub { sleep 2; lock $zoo; cond_signal $zoo; 1} ); { lock $zoo; cond_wait $zoo; ok( 1, "We've come back from the thread!" ); } ok( $thread->join,"Check if came back correctly from thread" ); { lock $zoo; my $data = 'x' x 100000; $thread = threads->new( sub { lock $zoo; return $zoo eq $data; } ); $zoo = $data; } ok( $thread->join,"Check if it was the same inside the thread" ); #$thread = threads->new( sub { sleep 2; cond_signal $zoo} ); #lock $zoo; #cond_wait $zoo; #ok( 1, "We've come back from the thread!" ); #$thread->join; #== cond_timedwait ================================================= $zoo = threads->tid; $thread = threads->new( sub { sleep 2; { lock $zoo; cond_signal $zoo; } sleep 10; lock $zoo; cond_signal $zoo; $zoo = threads->tid; 1} ); { lock $zoo; cond_wait $zoo; my $start_ts = time(); my $ret = cond_timedwait $zoo, time() + 2; cmp_ok( $zoo, '==', threads->tid, "check that cond_timedwait exited due to timeout (before signal)" ); cmp_ok( !$ret, '==', 1, "check that cond_timedwait exited with correct value" ); $ret = cond_timedwait $zoo, time() + 30; cmp_ok( $zoo, '==', $thread->tid, "check that cond_timedwait signal was handled correctly" ); cmp_ok( time() - $start_ts, '<', 30, "check that cond_timedwait exited due to signal and not after it expired" ); cmp_ok( $ret, '==', 1, "check that cond_timedwait exited with correct value" ); sleep 1; } ok( $thread->join,"Check if came back correctly from thread" ); $zoo = threads->tid; my ($thread1, $thread2, $thread3); $thread1 = threads->new( sub { lock $zoo; cond_timedwait $zoo, time() + 40; $zoo = threads->tid; 1} ); $thread2 = threads->new( sub { lock $zoo; cond_timedwait $zoo, time() + 1; $zoo = threads->tid; 1} ); $thread3 = threads->new( sub { lock $zoo; cond_timedwait $zoo, time() + 30; $zoo = threads->tid; 1} ); { my $start_ts = time(); sleep 5; cmp_ok( $zoo, '==', $thread2->tid, "check that thread2 cond_timedwait exited due to timeout" ); { lock $zoo; cond_signal $zoo; } { lock $zoo; cond_signal $zoo; } ok( $thread1->join,"Check if came back correctly from thread1" ); ok( $thread2->join,"Check if came back correctly from thread2" ); ok( $thread3->join,"Check if came back correctly from thread3" ); cmp_ok( time() - $start_ts, '<', 30, "check that thread1 & thread3 exited due to cond_signal and not after cond_timedwait expired" ); } $thread1 = threads->new( sub { lock $zoo; cond_timedwait $zoo, time() + 40; 1} ); $thread2 = threads->new( sub { lock $zoo; cond_timedwait $zoo, time() + 30; 1} ); $thread3 = threads->new( sub { lock $zoo; cond_wait $zoo; 1} ); { my $start_ts = time(); sleep 5; { lock $zoo; cond_broadcast $zoo; } ok( $thread1->join,"Check if came back correctly from thread1" ); ok( $thread2->join,"Check if came back correctly from thread2" ); ok( $thread3->join,"Check if came back correctly from thread3" ); cmp_ok( time() - $start_ts, '<', 30, "check that thread1, thread2, and thread3 exited due to cond_broadcast" ); } #== cond_wait, cond_timedwait second forms ========================= my $lockvar : shared; $zoo = threads->tid; $thread = threads->new( sub { sleep 2; { lock $zoo; cond_signal $zoo; } sleep 2; lock $zoo; cond_signal $zoo; lock $lockvar; sleep 5; $zoo = threads->tid; 1} ); { { lock $zoo; cond_wait $zoo; } lock $lockvar; cond_wait $zoo, $lockvar; sleep 1; cmp_ok( $zoo, '==', threads->tid, "check that main thread received signal before thread could lock it" ); } ok( $thread->join,"Check if came back correctly from thread" ); $zoo = threads->tid; $thread = threads->new( sub { sleep 2; { lock $zoo; cond_signal $zoo; } sleep 5; lock $zoo; cond_signal $zoo; lock $zoo; $zoo = threads->tid; 1} ); { { lock $zoo; cond_wait $zoo; } my $start_ts = time(); lock $lockvar; my $ret = cond_timedwait $zoo, time() + 2, $lockvar; cmp_ok( $zoo, '==', threads->tid, "check that cond_timedwait exited due to timeout (before signal)" ); cmp_ok( !$ret, '==', 1, "check that cond_timedwait exited with correct value" ); $ret = cond_timedwait $zoo, time() + 30, $lockvar; sleep 2; lock $zoo; cmp_ok( $zoo, '==', $thread->tid, "check that cond_timedwait signal was handled correctly" ); cmp_ok( time() - $start_ts, '<', 30, "check that cond_timedwait exited due to signal and not after it expired" ); cmp_ok( $ret, '==', 1, "check that cond_timedwait exited with correct value" ); sleep 1; } ok( $thread->join,"Check if came back correctly from thread" ); $thread1 = threads->new( sub { lock $lockvar; cond_timedwait $zoo, time() + 40, $lockvar; 1} ); $thread2 = threads->new( sub { lock $lockvar; cond_timedwait $zoo, time() + 30, $lockvar; 1} ); $thread3 = threads->new( sub { lock $lockvar; cond_wait $zoo, $lockvar; 1} ); { my $start_ts = time(); sleep 5; { lock $lockvar; lock $zoo; cond_broadcast $zoo; } ok( $thread1->join,"Check if came back correctly from thread1" ); ok( $thread2->join,"Check if came back correctly from thread2" ); ok( $thread3->join,"Check if came back correctly from thread3" ); cmp_ok( time() - $start_ts, '<', 30, "check that thread1, thread2, and thread3 exited due to cond_broadcast" ); } #== threads->list, is_running, is_joinable, isdetached ============= $thread1 = threads->new( sub { lock $lockvar; cond_wait $lockvar; 1}); $thread2 = threads->new( sub { { lock $test_lock; ok( !threads->is_detached(),"Check that thread->is_detached returns false"); } lock $zoo; cond_wait $zoo; 1 }); $thread3 = threads->new( sub { lock $lockvar; cond_wait $lockvar; { lock $test_lock; ok( threads->is_detached(),"Check that thread->is_detached returns true"); } 1 }); $thread3->detach; { sleep 5; lock $lockvar; lock $zoo; my $num; { lock $test_lock; ok( $thread1->is_running(),"Check that thread is_running returns true" ); ok( !$thread1->is_joinable(),"Check that thread is_joinable returns false" ); ok( !$thread1->is_detached(),"Check that thread is_detached returns false" ); ok( $thread3->is_running(),"Check that thread is_running returns true" ); ok( !$thread3->is_joinable(),"Check that thread is_joinable returns false" ); ok( $thread3->is_detached(),"Check that thread is_detached returns true" ); cmp_ok( $num=threads->list(threads::all), '==', 2,"Check for non-joined, non-detached threads" ); cmp_ok( $num=threads->list(threads::running), '==', 2,"Check for non-detached threads that are still running" ); cmp_ok( $num=threads->list(threads::joinable), '==', 0,"Check for non-joined, non-detached threads that have finished running" ); } cond_broadcast $lockvar; cond_signal $zoo; } { sleep 3; my $num; { lock $test_lock; cmp_ok( $num=threads->list(threads::all), '==', 2,"Check for non-joined, non-detached threads" ); cmp_ok( $num=threads->list(threads::running), '==', 0,"Check for non-detached threads that are still running" ); cmp_ok( $num=threads->list(threads::joinable), '==', 2,"Check for non-joined, non-detached threads that have finished running" ); ok( $thread1->is_joinable(),"Check that thread is_joinable returns true" ); } $thread1->join(); { lock $test_lock; ok( !$thread1->is_running(),"Check that thread is_running returns false" ); ok( !$thread1->is_joinable(),"Check that thread is_joinable returns false" ); cmp_ok( $num=threads->list(threads::all), '==', 1,"Check for non-joined, non-detached threads" ); cmp_ok( $num=threads->list(threads::joinable), '==', 1,"Check for non-joined, non-detached threads that have finished running" ); } $thread2->join(); } #== thread stack size ============================================== cmp_ok( threads->get_stack_size(), '==', 0, "Check for default thread stack size" ); { threads->set_stack_size( 64*4096 ); cmp_ok( threads->get_stack_size(), '>', 0, "Check for custom thread stack size" ); $thread1 = threads->new( sub { 1 }); cmp_ok( $thread1->get_stack_size(), '>', 0, "Check for custom thread stack size" ); $thread1->join(); threads->set_stack_size( 0 ); cmp_ok( threads->get_stack_size(), '==', 0, "Check for default thread stack size" ); $thread1 = threads->new({ 'stack' => 4096*64 }, sub { 1 }); cmp_ok( $thread1->get_stack_size(), '>', 0, "Check for custom thread stack size" ); $thread2 = $thread1->create( sub { 1 } ); cmp_ok( $thread2->get_stack_size(), '==', 4096*64, "Check for default stack size" ); $thread1->join(); $thread2->join(); } #== thread context ================================================= { my $scalar; @list = (); ($thread1) = threads->create( sub { { lock $test_lock; ok( threads->wantarray(),"Check thread implicit context is list" ); } return qw(a b c); } ); sleep 2; #Test::More race-condition protection { lock $test_lock; ok( $thread1->wantarray(), "Check thread implicit context is list" ); } @list = $thread1->join(); is( join('',@list), 'abc', 'check list return result' ); $thread1 = threads->create( sub { { lock $test_lock; cmp_ok( threads->wantarray(), '==', 0, "Check thread implicit context is scalar" ); } return 'abc'; } ); sleep 2; #Test::More race-condition protection { lock $test_lock; cmp_ok( $thread1->wantarray(), 'eq', '', "Check thread implicit context is scalar" ); } $scalar = $thread1->join(); { lock $test_lock; is( $scalar, 'abc', 'check scalar return result' ); } threads->create( sub { { lock $test_lock; ok( !defined threads->wantarray(), "Check thread implicit context is void" ); } return; } ); $_->join() foreach threads->list(); $thread1 = threads->create( { 'context' => 'list' }, sub { { lock $test_lock; ok( threads->wantarray(),"Check thread context is list" ); } return 'def'; } ); sleep 2; #Test::More race-condition protection { lock $test_lock; ok( $thread1->wantarray(), "Check thread context is list" ); } @list = $thread1->join(); { lock $test_lock; is( join('',@list), 'def', 'check array return result' ); } $thread1 = threads->create( { 'context' => 'scalar' }, sub { { lock $test_lock; cmp_ok( threads->wantarray(), '==', 0, "Check thread context is scalar" ); } return qw(a b c); } ); sleep 2; #Test::More race-condition protection { lock $test_lock; cmp_ok( $thread1->wantarray(), 'eq', '', "Check thread context is scalar" ); } $scalar = $thread1->join(); { lock $test_lock; is( $scalar, 'c', 'check scalar return result' ); } $thread1 = threads->create( { 'context' => 'void' }, sub { { lock $test_lock; ok( !defined threads->wantarray(), "Check thread context is void" ); } return 'abc'; } ); sleep 2; #Test::More race-condition protection { lock $test_lock; ok( !defined $thread1->wantarray(),"Check thread context is void" ); } $scalar = $thread1->join(); { lock $test_lock; ok( !defined $scalar, 'check void return result' ); } } #== stringify ====================================================== isnt( "$thread1", $thread1->tid, "Check that stringify is not enabled" ); import forks qw(stringify); $thread1 = threads->new( sub { 1 }); $thread1->join(); is( "$thread1", $thread1->tid, "Check that stringify works" ); #=================================================================== 1; forks-0.34/t/forks02.t0100755000076500000240000000565711126450255012457 0ustar games#!/usr/local/bin/perl -T -w BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; @INC = '../lib'; } elsif (!grep /blib/, @INC) { chdir 't' if -d 't'; unshift @INC, ('../blib/lib', '../blib/arch'); } } BEGIN {delete $ENV{THREADS_DEBUG}} # no debugging during testing! use forks; # must be done _before_ Test::More which loads real threads.pm use forks::shared; my $times = 100; diag( <new->reset; } } # Patch Test::Builder to add fork-thread awareness { no warnings 'redefine'; my $_sanity_check_old = \&Test::Builder::_sanity_check; *Test::Builder::_sanity_check = sub { my $self = $_[0]; # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. if( $self->{Original_Pid} != $$ ) { return; } $_sanity_check_old->(@_); }; } use Test::More tests => 6; #= ARRAY ============================================================== { my @array : shared; my $tied = tied( @array ); isa_ok( $tied,'threads::shared', 'check object type' ); my @thread; my $count : shared; $count = 0; #warn "lock = ".(\&lock)."\n"; push( @thread,threads->new( sub { while (1) { {lock( $count ); return if $count == $times; $count++; push( @array,0+$count ); } } } ) ) foreach 1..10; $_->join foreach @thread; my $check; $check .= $_ foreach 1..$times; is( join('',@array),$check, 'check array contents' ); pop( @array ) foreach 1..$times; is( join('',@array),'', 'check array contents' ); } #= HASH =============================================================== { my %hash : shared; my $tied = tied( %hash ); isa_ok( $tied,'threads::shared', 'check object type' ); my @thread; my $count : shared; $count = 0; my $sub = sub { while (1) { {lock( $count ); return if $count == $times; $count++; $hash{$count} = $count; } } }; foreach (1..10) { my $thread = threads->new( $sub ); push @thread,$thread; } $_->join foreach @thread; my $check; $check .= ($_.$_) foreach 1..$times; my $hash; $hash .= ($_.$hash{$_}) foreach (sort {$a <=> $b} keys %hash); is( $hash,$check, 'check hash contents' ); delete( $hash{$_} ) foreach 1..$times; is( join('',%hash),'', 'check hash contents' ); } #====================================================================== 1; forks-0.34/t/forks03.t0100755000076500000240000001675311126450255012457 0ustar games#!/usr/local/bin/perl -w BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; @INC = '../lib'; } elsif (!grep /blib/, @INC) { chdir 't' if -d 't'; unshift @INC, ('../blib/lib', '../blib/arch'); } } BEGIN {delete $ENV{THREADS_DEBUG}} # no debugging during testing! use forks; # must be done _before_ Test::More which loads real threads.pm use forks::shared; diag( <new->reset; } } # Patch Test::Builder to add fork-thread awareness { no warnings 'redefine'; my $_sanity_check_old = \&Test::Builder::_sanity_check; *Test::Builder::_sanity_check = sub { my $self = $_[0]; # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. if( $self->{Original_Pid} != $$ ) { return; } $_sanity_check_old->(@_); }; } use Test::More tests => 64; use strict; use warnings; my $dummy = {}; bless ($dummy, 'simple'); ok(ref($dummy) eq 'simple', "regular blessing still works"); my ($hobj, $aobj, $sobj) : shared; $hobj = &share({}); $aobj = &share([]); my $sref = \do{ my $x }; share($sref); $sobj = $sref; threads->new(sub { # Bless objects bless $hobj, 'foo'; bless $aobj, 'bar'; bless $sobj, 'baz'; # Add data to objects $$aobj[0] = bless(&share({}), 'yin'); $$aobj[1] = bless(&share([]), 'yang'); $$aobj[2] = $sobj; $$hobj{'hash'} = bless(&share({}), 'yin'); $$hobj{'array'} = bless(&share([]), 'yang'); $$hobj{'scalar'} = $sobj; $$sobj = 3; # Test objects in child thread ok(ref($hobj) eq 'foo', "hash blessing does work"); ok(ref($aobj) eq 'bar', "array blessing does work"); ok(ref($sobj) eq 'baz', "scalar blessing does work"); ok($$sobj eq '3', "scalar contents okay"); ok(ref($$aobj[0]) eq 'yin', "blessed hash in array"); ok(ref($$aobj[1]) eq 'yang', "blessed array in array"); ok(ref($$aobj[2]) eq 'baz', "blessed scalar in array"); ok(${$$aobj[2]} eq '3', "blessed scalar in array contents"); ok(ref($$hobj{'hash'}) eq 'yin', "blessed hash in hash"); ok(ref($$hobj{'array'}) eq 'yang', "blessed array in hash"); ok(ref($$hobj{'scalar'}) eq 'baz', "blessed scalar in hash"); ok(${$$hobj{'scalar'}} eq '3', "blessed scalar in hash contents"); })->join; # Test objects in parent thread ok(ref($hobj) eq 'foo', "hash blessing does work"); ok(ref($aobj) eq 'bar', "array blessing does work"); ok(ref($sobj) eq 'baz', "scalar blessing does work"); ok($$sobj eq '3', "scalar contents okay"); ok(ref($$aobj[0]) eq 'yin', "blessed hash in array"); ok(ref($$aobj[1]) eq 'yang', "blessed array in array"); ok(ref($$aobj[2]) eq 'baz', "blessed scalar in array"); ok(${$$aobj[2]} eq '3', "blessed scalar in array contents"); ok(ref($$hobj{'hash'}) eq 'yin', "blessed hash in hash"); ok(ref($$hobj{'array'}) eq 'yang', "blessed array in hash"); ok(ref($$hobj{'scalar'}) eq 'baz', "blessed scalar in hash"); ok(${$$hobj{'scalar'}} eq '3', "blessed scalar in hash contents"); threads->new(sub { # Rebless objects bless $hobj, 'oof'; bless $aobj, 'rab'; bless $sobj, 'zab'; my $data = $$aobj[0]; bless $data, 'niy'; $$aobj[0] = $data; $data = $$aobj[1]; bless $data, 'gnay'; $$aobj[1] = $data; $data = $$hobj{'hash'}; bless $data, 'niy'; $$hobj{'hash'} = $data; $data = $$hobj{'array'}; bless $data, 'gnay'; $$hobj{'array'} = $data; $$sobj = 'test'; })->join; # Test reblessing ok(ref($hobj) eq 'oof', "hash reblessing does work"); ok(ref($aobj) eq 'rab', "array reblessing does work"); ok(ref($sobj) eq 'zab', "scalar reblessing does work"); ok($$sobj eq 'test', "scalar contents okay"); ok(ref($$aobj[0]) eq 'niy', "reblessed hash in array"); ok(ref($$aobj[1]) eq 'gnay', "reblessed array in array"); ok(ref($$aobj[2]) eq 'zab', "reblessed scalar in array"); ok(${$$aobj[2]} eq 'test', "reblessed scalar in array contents"); ok(ref($$hobj{'hash'}) eq 'niy', "reblessed hash in hash"); ok(ref($$hobj{'array'}) eq 'gnay', "reblessed array in hash"); ok(ref($$hobj{'scalar'}) eq 'zab', "reblessed scalar in hash"); ok(${$$hobj{'scalar'}} eq 'test', "reblessed scalar in hash contents"); #36 ok(UNIVERSAL::isa($hobj, 'oof') == 1, "hash object with UNIVERSAL::isa does work"); ok(UNIVERSAL::isa($aobj, 'rab') == 1, "array object with UNIVERSAL::isa does work"); ok(UNIVERSAL::isa($sobj, 'zab') == 1, "scalar object with UNIVERSAL::isa does work"); ok(UNIVERSAL::isa($$aobj[0], 'niy') == 1, "hash in array object with UNIVERSAL::isa does work"); ok(UNIVERSAL::isa($$aobj[1], 'gnay') == 1, "array in array object with UNIVERSAL::isa does work"); ok(UNIVERSAL::isa($$aobj[2], 'zab') == 1, "scalar in array object with UNIVERSAL::isa does work"); ok(UNIVERSAL::isa($$hobj{'hash'}, 'niy') == 1, "hash in hash object with UNIVERSAL::isa does work"); ok(UNIVERSAL::isa($$hobj{'array'}, 'gnay') == 1, "array in hash object with UNIVERSAL::isa does work"); ok(UNIVERSAL::isa($$hobj{'scalar'}, 'zab') == 1, "scalar in hash object with UNIVERSAL::isa does work"); ok($hobj->isa('oof') == 1, "hash object method isa() does work"); ok($aobj->isa('rab') == 1, "array object method isa() does work"); ok($sobj->isa('zab') == 1, "scalar object method isa() does work"); ok($$aobj[0]->isa('niy') == 1, "hash in array object method isa() does work"); ok($$aobj[1]->isa('gnay') == 1, "array in array object method isa() does work"); ok($$aobj[2]->isa('zab') == 1, "scalar in array object method isa() does work"); ok($$hobj{'hash'}->isa('niy') == 1, "hash in hash object method isa() does work"); ok($$hobj{'array'}->isa('gnay') == 1, "array in hash object method isa() does work"); ok($$hobj{'scalar'}->isa('zab') == 1, "scalar in hash object method isa() does work"); sub oof::test_me { return "yes1"; } sub rab::test_me { return "yes2"; } sub zab::test_me { return "yes3"; } sub niy::test_me { return "yes4"; } sub gnay::test_me { return "yes5"; } ok($hobj->test_me eq "yes1", "hash object method does work"); ok($aobj->test_me eq "yes2", "array object method does work"); ok($sobj->test_me eq "yes3", "scalar object method does work"); ok($$aobj[0]->test_me eq "yes4", "hash in array object method does work"); ok($$aobj[1]->test_me eq "yes5", "array in array object method does work"); ok($$aobj[2]->test_me eq "yes3", "scalar in array object method does work"); ok($$hobj{'hash'}->test_me eq "yes4", "hash in hash object method does work"); ok($$hobj{'array'}->test_me eq "yes5", "array in hash object method does work"); ok($$hobj{'scalar'}->test_me eq "yes3", "scalar in hash object method does work"); 1; forks-0.34/t/forks04.t0100755000076500000240000003531611126451072012452 0ustar games#!/usr/local/bin/perl -w BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; @INC = '../lib'; } elsif (!grep /blib/, @INC) { chdir 't' if -d 't'; unshift @INC, ('../blib/lib', '../blib/arch'); } } BEGIN {delete $ENV{THREADS_DEBUG}} # no debugging during testing! use Config; my ($skip_all, $num_tests); BEGIN { $skip_all = 0; $num_tests = 97; eval { require threads; # must be done _before_ Test::More which loads real threads.pm require threads::shared; unless ($forks::threads_override || $forks::threads_override) { $skip_all = 1; $num_tests = 1; } }; if ($@) { $skip_all = 1; $num_tests = 1; eval { *cond_wait = *cond_timedwait = sub {}; } unless $Config{useithreads}; } } # do the following to prevent unnecessary test script errors BEGIN { if (!defined $threads::VERSION || $threads::VERSION < 1.34) { package threads; *all = *running = *joinable = sub {}; package main; print <new->reset; } } # Patch Test::Builder to add fork-thread awareness { no warnings 'redefine'; my $_sanity_check_old = \&Test::Builder::_sanity_check; *Test::Builder::_sanity_check = sub { my $self = $_[0]; # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. if( $self->{Original_Pid} != $$ ) { return; } $_sanity_check_old->(@_); }; } # Now load Test::More BEGIN { require Test::More; import Test::More tests => $num_tests; } use strict; use warnings; diag( <isthread if defined($pid); threads->can('exit') ? threads->exit : exit; } sleep 3; # make sure fork above has started to ensure tid's are in sync my $t1 = threads->new( sub { threads->tid } ); ok( $t1,'check whether we can start a thread with new()' ); my $t2 = threads->create( sub { threads->tid } ); ok( $t2,'check whether we can start a thread with create()' ); my $t3 = async( sub { threads->object( threads->tid )->tid } ); ok( $t3,'check whether we can start a thread with async()' ); my %tid; $tid{$_->tid} = undef foreach threads->list; is( join('',sort keys %tid),'234','check tids of all threads' ); is( $t3->join,'4','check return value thread 3' ); is( $t2->join,'3','check return value thread 2' ); is( $t1->join,'2','check return value thread 1' ); #== SCALAR ========================================================= my $scalar = 10; share( $scalar ); share( $scalar ); #tests that we quietly support re-sharing a shared variable ok(is_shared( $scalar ), 'check if variable is_shared' ); my $tied = tied( $scalar ); isa_ok( $tied,'threads::shared', 'check tied object type' ); ok( defined $scalar, 'check scalar fetch' ); $scalar = 10; $scalar++; cmp_ok( $scalar,'==',11, 'check scalar increment' ); $scalar = 'Apenootjes'; is( $scalar,'Apenootjes', 'check scalar fetch' ); threads->new( sub {$scalar = 'from thread'} )->join; is( $scalar,'from thread', 'check scalar fetch' ); #== ARRAY ========================================================== my @array = qw(a b c); share( @array ); $tied = tied( @array ); isa_ok( $tied,'threads::shared', 'check tied object type' ); is( join('',@array),'', 'check array fetch' ); push( @array,qw(a b c) ); push( @array,qw(d e f) ); is( join('',@array),'abcdef', 'check array fetch' ); threads->new( sub {push( @array,qw(g h i) )} )->join; is( join('',@array),'abcdefghi', 'check array fetch' ); shift( @array ); is( join('',@array),'bcdefghi', 'check array fetch' ); unshift( @array,'a' ); is( join('',@array),'abcdefghi', 'check array fetch' ); pop( @array ); is( join('',@array),'abcdefgh', 'check array fetch' ); push( @array,'i' ); is( join('',@array),'abcdefghi', 'check array fetch' ); eval{ splice( @array,3,3 ); }; like( $@,qr#^Splice not implemented for shared arrays#,'check splice' ); is( join('',map {$_ || ''} @array),'abcdefghi', 'Check that splice did nothing' ); @array = qw(d e f d e f g h i); delete( $array[0] ); is( join('',map {$_ || ''} @array),'efdefghi', 'check array fetch' ); @array = qw(a b c d e f g h i); is( join('',@array),'abcdefghi', 'check array fetch' ); cmp_ok( $#array,'==',8, 'check size' ); ok( exists( $array[8] ), 'check whether array element exists' ); ok( !exists( $array[9] ), 'check whether array element exists' ); $#array = 10; cmp_ok( scalar(@array),'==',11, 'check number of elements' ); is( join('',map {$_ || ''} @array),'abcdefghi', 'check array fetch' ); ok( !exists( $array[10] ), 'check whether array element exists' ); $array[10] = undef; ok( exists( $array[10] ), 'check whether array element exists' ); ok( !exists( $array[11] ), 'check whether array element exists' ); ok( !defined( $array[10] ), 'check whether array element defined' ); ok( !defined( $array[11] ), 'check whether array element defined' ); cmp_ok( scalar(@array),'==',11, 'check number of elements' ); @array = (); cmp_ok( scalar(@array),'==',0, 'check number of elements' ); is( join('',@array),'', 'check array fetch' ); #== HASH =========================================================== my %hash = (a => 'A'); share( %hash ); $tied = tied( %hash ); isa_ok( $tied,'threads::shared', 'check tied object type' ); is( $hash{'a'},undef, 'check hash fetch' ); $hash{'a'} = 'A'; $hash{'b'} = 'B'; is( $hash{'b'},'B', 'check hash fetch' ); is( join('',sort keys %hash),'ab', 'check hash keys' ); ok( !exists( $hash{'c'} ), 'check existence of key' ); threads->new( sub { $hash{'c'} = 'C' } )->join; ok( exists( $hash{'c'} ), 'check existence of key' ); is( $hash{'c'},'C', 'check hash fetch' ); is( join('',sort keys %hash),'abc', 'check hash keys' ); my %otherhash = %hash; is( join('',sort keys %otherhash),'abc','check hash keys' ); my @list; while (my ($key,$value) = each %hash) { push( @list,$key,$value ) } is( join('',sort @list),'ABCabc', 'check all eaches' ); delete( $hash{'b'} ); is( join('',sort keys %hash),'ac', 'check hash keys' ); %hash = (); cmp_ok( scalar(keys %hash),'==',0, 'check number of elements' ); is( join('',keys %hash),'', 'check hash fetch' ); #== errors ========================================================= my $foo; eval {lock $foo}; like( $@,qr#^lock can only be used on shared values#,'check unshared var' ); my $bar : shared; eval {cond_wait $bar}; like( $@,qr#^You need a lock before you can cond_wait#,'check unlocked var' ); eval {cond_timedwait $bar, time() + 5}; like( $@,qr#^You need a lock before you can cond_timedwait#,'check unlocked var' ); eval {lock $bar}; is( $@,'','check locking shared var' ); eval {lock $bar; cond_signal $bar}; is( $@,'','check locking and signalling shared var' ); #== fixed bugs ===================================================== my $zoo : shared; my $thread = threads->new( sub { sleep 2; lock $zoo; cond_signal $zoo; 1} ); { lock $zoo; cond_wait $zoo; ok( 1, "We've come back from the thread!" ); } ok( $thread->join,"Check if came back correctly from thread" ); { lock $zoo; my $data = 'x' x 100000; $thread = threads->new( sub { lock $zoo; return $zoo eq $data; } ); $zoo = $data; } ok( $thread->join,"Check if it was the same inside the thread\n" ); #$thread = threads->new( sub { sleep 2; cond_signal $zoo} ); #lock $zoo; #cond_wait $zoo; #ok( 1, "We've come back from the thread!" ); #$thread->join; #== cond_timedwait ================================================= $zoo = threads->tid; $thread = threads->new( sub { sleep 2; { lock $zoo; cond_signal $zoo; } sleep 10; lock $zoo; cond_signal $zoo; $zoo = threads->tid; 1} ); { lock $zoo; cond_wait $zoo; my $start_ts = time(); my $ret = cond_timedwait $zoo, time() + 2; cmp_ok( $zoo, '==', threads->tid, "check that cond_timedwait exited due to timeout (before signal)" ); cmp_ok( !$ret, '==', 1, "check that cond_timedwait exited with correct value" ); $ret = cond_timedwait $zoo, time() + 30; cmp_ok( $zoo, '==', $thread->tid, "check that cond_timedwait signal was handled correctly" ); cmp_ok( time() - $start_ts, '<', 30, "check that cond_timedwait exited due to signal and not after it expired" ); cmp_ok( $ret, '==', 1, "check that cond_timedwait exited with correct value" ); sleep 1; } ok( $thread->join,"Check if came back correctly from thread" ); $zoo = threads->tid; my ($thread1, $thread2, $thread3); $thread1 = threads->new( sub { lock $zoo; cond_timedwait $zoo, time() + 40; $zoo = threads->tid; 1} ); $thread2 = threads->new( sub { lock $zoo; cond_timedwait $zoo, time() + 1; $zoo = threads->tid; 1} ); $thread3 = threads->new( sub { lock $zoo; cond_timedwait $zoo, time() + 30; $zoo = threads->tid; 1} ); { my $start_ts = time(); sleep 5; cmp_ok( $zoo, '==', $thread2->tid, "check that thread2 cond_timedwait exited due to timeout" ); { lock $zoo; cond_signal $zoo; } { lock $zoo; cond_signal $zoo; } ok( $thread1->join,"Check if came back correctly from thread1" ); ok( $thread2->join,"Check if came back correctly from thread2" ); ok( $thread3->join,"Check if came back correctly from thread3" ); cmp_ok( time() - $start_ts, '<', 30, "check that thread1 & thread3 exited due to cond_signal and not after cond_timedwait expired" ); } $thread1 = threads->new( sub { lock $zoo; cond_timedwait $zoo, time() + 40; 1} ); $thread2 = threads->new( sub { lock $zoo; cond_timedwait $zoo, time() + 30; 1} ); $thread3 = threads->new( sub { lock $zoo; cond_wait $zoo; 1} ); { my $start_ts = time(); sleep 5; { lock $zoo; cond_broadcast $zoo; } ok( $thread1->join,"Check if came back correctly from thread1" ); ok( $thread2->join,"Check if came back correctly from thread2" ); ok( $thread3->join,"Check if came back correctly from thread3" ); cmp_ok( time() - $start_ts, '<', 30, "check that thread1, thread2, and thread3 exited due to cond_broadcast" ); } #== cond_wait, cond_timedwait second forms ========================= my $lockvar : shared; $zoo = threads->tid; $thread = threads->new( sub { sleep 2; { lock $zoo; cond_signal $zoo; } sleep 2; lock $zoo; cond_signal $zoo; lock $lockvar; sleep 5; $zoo = threads->tid; 1} ); { { lock $zoo; cond_wait $zoo; } lock $lockvar; cond_wait $zoo, $lockvar; sleep 1; cmp_ok( $zoo, '==', threads->tid, "check that main thread received signal before thread could lock it" ); } ok( $thread->join,"Check if came back correctly from thread" ); $zoo = threads->tid; $thread = threads->new( sub { sleep 2; { lock $zoo; cond_signal $zoo; } sleep 5; lock $zoo; cond_signal $zoo; lock $zoo; $zoo = threads->tid; 1} ); { { lock $zoo; cond_wait $zoo; } my $start_ts = time(); lock $lockvar; my $ret = cond_timedwait $zoo, time() + 2, $lockvar; cmp_ok( $zoo, '==', threads->tid, "check that cond_timedwait exited due to timeout (before signal)" ); cmp_ok( !$ret, '==', 1, "check that cond_timedwait exited with correct value" ); $ret = cond_timedwait $zoo, time() + 30, $lockvar; sleep 2; lock $zoo; cmp_ok( $zoo, '==', $thread->tid, "check that cond_timedwait signal was handled correctly" ); cmp_ok( time() - $start_ts, '<', 30, "check that cond_timedwait exited due to signal and not after it expired" ); cmp_ok( $ret, '==', 1, "check that cond_timedwait exited with correct value" ); sleep 1; } ok( $thread->join,"Check if came back correctly from thread" ); $thread1 = threads->new( sub { lock $lockvar; cond_timedwait $zoo, time() + 40, $lockvar; 1} ); $thread2 = threads->new( sub { lock $lockvar; cond_timedwait $zoo, time() + 30, $lockvar; 1} ); $thread3 = threads->new( sub { lock $lockvar; cond_wait $zoo, $lockvar; 1} ); { my $start_ts = time(); sleep 5; { lock $lockvar; lock $zoo; cond_broadcast $zoo; } ok( $thread1->join,"Check if came back correctly from thread1" ); ok( $thread2->join,"Check if came back correctly from thread2" ); ok( $thread3->join,"Check if came back correctly from thread3" ); cmp_ok( time() - $start_ts, '<', 30, "check that thread1, thread2, and thread3 exited due to cond_broadcast" ); } #90 #== threads->list ================================================== $thread1 = threads->new( sub { lock $lockvar; cond_wait $lockvar; 1}); $thread2 = threads->new( sub { lock $zoo; cond_wait $zoo; 1}); $thread3 = threads->new( sub { lock $lockvar; cond_wait $lockvar; 1})->detach; { sleep 5; lock $lockvar; lock $zoo; my $num; cmp_ok( $num=threads->list(threads::all), '==', 2,"Check for non-joined, non-detached threads" ); cmp_ok( $num=threads->list(threads::running), '==', 2,"Check for non-detached threads that are still running" ); cmp_ok( $num=threads->list(threads::joinable), '==', 0,"Check for non-joined, non-detached threads that have finished running" ); cond_broadcast $lockvar; cond_signal $zoo; } { sleep 3; my $num; cmp_ok( $num=threads->list(threads::all), '==', 2,"Check for non-joined, non-detached threads" ); cmp_ok( $num=threads->list(threads::running), '==', 0,"Check for non-detached threads that are still running" ); cmp_ok( $num=threads->list(threads::joinable), '==', 2,"Check for non-joined, non-detached threads that have finished running" ); $thread1->join(); cmp_ok( $num=threads->list(threads::all), '==', 1,"Check for non-joined, non-detached threads" ); cmp_ok( $num=threads->list(threads::joinable), '==', 1,"Check for non-joined, non-detached threads that have finished running" ); $thread2->join(); } #98 #=================================================================== } #SKIP 1; forks-0.34/t/forks05.t0100755000076500000240000000611711156544651012461 0ustar games#!/usr/local/bin/perl -w my @custom_inc; BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; @custom_inc = @INC = '../lib'; } elsif (!grep /blib/, @INC) { chdir 't' if -d 't'; unshift @INC, (@custom_inc = ('../blib/lib', '../blib/arch')); } } BEGIN {delete $ENV{THREADS_DEBUG}} # no debugging during testing! # "Unpatch" Test::More, who internally tries to disable threads BEGIN { no warnings 'redefine'; if ($] < 5.008001) { require forks::shared::global_filter; import forks::shared::global_filter 'Test::Builder'; require Test::Builder; *Test::Builder::share = \&threads::shared::share; *Test::Builder::lock = \&threads::shared::lock; Test::Builder->new->reset; } } # Patch Test::Builder to add fork-thread awareness { no warnings 'redefine'; my $_sanity_check_old = \&Test::Builder::_sanity_check; *Test::Builder::_sanity_check = sub { my $self = $_[0]; # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. if( $self->{Original_Pid} != $$ ) { return; } $_sanity_check_old->(@_); }; } use Test::More tests => 4; use Config; use strict; use warnings; diag( <new(sub { exit($desired_exit_val);} )->join(); sleep 10; sleep 10;'}; my $cmd4 = qq{$secure_perl_path $libs -e '} .q|BEGIN {delete $ENV{THREADS_DEBUG}; $ENV{THREADS_DAEMON_MODEL} = 1;}| .qq{ use forks; threads->new(sub { exit($desired_exit_val);} )->join(); sleep 10; sleep 10;'}; my $exit_val = system($cmd) >> 8; cmp_ok($exit_val, '==', $desired_exit_val, 'Check that perl exit value is correct with forks'); $exit_val = system($cmd2) >> 8; cmp_ok($exit_val, '==', $desired_exit_val, 'Check that perl exit value is correct with forks'); SKIP: { #TODO perl 5.6 compatibility, unclear why exit() is not handled (possibly a signal issue) skip 'Case not supported in perl 5.6 (yet)', 1; $exit_val = system($cmd3) >> 8; cmp_ok($exit_val, '==', $desired_exit_val, 'Check that perl exit value is correct with forks'); } $exit_val = system($cmd4) >> 8; cmp_ok($exit_val, '==', $desired_exit_val, 'Check that perl exit value is correct with forks'); 1; forks-0.34/t/forks06.t0100755000076500000240000001011311126450255012442 0ustar games#!/usr/local/bin/perl -w my @custom_inc; BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; @custom_inc = @INC = '../lib'; } elsif (!grep /blib/, @INC) { chdir 't' if -d 't'; unshift @INC, (@custom_inc = ('../blib/lib', '../blib/arch')); } } BEGIN {delete $ENV{THREADS_DEBUG}} # no debugging during testing! no if $] >= 5.008, warnings => 'threads'; use forks 'stringify'; # must be done _before_ Test::More which loads real threads.pm use forks::shared; diag( <new->reset; } } # Patch Test::Builder to add fork-thread awareness { no warnings 'redefine'; my $_sanity_check_old = \&Test::Builder::_sanity_check; *Test::Builder::_sanity_check = sub { my $self = $_[0]; # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. if( $self->{Original_Pid} != $$ ) { return; } $_sanity_check_old->(@_); }; } use Test::More tests => 11; use strict; use warnings; use POSIX qw(SIGTERM SIGKILL); use Time::HiRes qw(time); $SIG{ALRM} = sub { die 'Deadlock resolver failed to terminate a thread'; }; alarm 90; #give ourselves some time to complete these tests my $a : shared; my $b : shared; my $c : shared; sub deadlock_thread_pair { my $t1 = threads->new(sub { lock $a; sleep 2; lock $b; lock $c; }); my $t2 = threads->new(sub { lock $b; sleep 2; lock $a; lock $c; }); return ($t1, $t2); } #== manually detect and resolve ==================================== my ($thr1, $thr2); { lock $c; ($thr1, $thr2) = deadlock_thread_pair(); sleep 5; ok($thr1->is_deadlocked(), "Check if thread $thr1 is deadlocked"); ok($thr2->is_deadlocked(), "Check if thread $thr2 is deadlocked"); forks::shared->import(deadlock => {resolve => 1}); #resolve the current deadlock sleep 3; if ($thr1->is_running()) { ok($thr1->is_running(), "Check if thread $thr1 is still running"); ok(!$thr2->is_running(), "Check if thread $thr2 was auto-killed"); } else { ok($thr2->is_running(), "Check if thread $thr2 is still running"); ok(!$thr1->is_running(), "Check if thread $thr1 was auto-killed"); } sleep 3; } $_->join() foreach threads->list(); #== auto-detect and resolve ======================================== forks::shared->set_deadlock_option(detect => 1); ($thr1, $thr2) = deadlock_thread_pair(); $_->join() foreach threads->list(); ok(!$thr1->is_running(), "Check if thread $thr1 completed (killed or joined)"); ok(!$thr2->is_running(), "Check if thread $thr2 completed (killed or joined)"); #== auto-detect and resolve with TERM signal ======================= SKIP: { skip 'No longer supported', 2; forks::shared->set_deadlock_option(resolve_signal => SIGTERM); ($thr1, $thr2) = deadlock_thread_pair(); $_->join() foreach threads->list(); ok(!$thr1->is_running(), "Check if thread $thr1 completed (killed or joined)"); ok(!$thr2->is_running(), "Check if thread $thr2 completed (killed or joined)"); } #== timed auto-detect and resolve ================================== my $min_time = 10; forks::shared->set_deadlock_option( detect => 1, period => $min_time, resolve_signal => SIGKILL); my $t = time(); ($thr1, $thr2) = deadlock_thread_pair(); $_->join() foreach threads->list(); cmp_ok($t ,'>', $min_time, 'Check that asynchronous deadlock detection worked' ); ok(!$thr1->is_running(), "Check if thread $thr1 completed (killed or joined)"); ok(!$thr2->is_running(), "Check if thread $thr2 completed (killed or joined)"); alarm 0; #success: reset alarm 1; forks-0.34/t/forks07.t0100755000076500000240000000404411126450255012451 0ustar games#!/usr/local/bin/perl -w my @custom_inc; BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; @custom_inc = @INC = '../lib'; } elsif (!grep /blib/, @INC) { chdir 't' if -d 't'; unshift @INC, (@custom_inc = ('../blib/lib', '../blib/arch')); } } BEGIN {delete $ENV{THREADS_DEBUG}} # no debugging during testing! no if $] >= 5.008, warnings => 'threads'; use forks; # must be done _before_ Test::More which loads real threads.pm use forks::shared; diag( <new->reset; } } # Patch Test::Builder to add fork-thread awareness { no warnings 'redefine'; my $_sanity_check_old = \&Test::Builder::_sanity_check; *Test::Builder::_sanity_check = sub { my $self = $_[0]; # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. if( $self->{Original_Pid} != $$ ) { return; } $_sanity_check_old->(@_); }; } use Test::More tests => 3; use strict; use warnings; my $thr = threads->new(sub { while (1) { sleep 1; } }); sleep 3; $thr->kill('TERM'); sleep 3; ok(!$thr->is_running(), 'Check that thread is no longer running'); my $gotsig : shared = 0; $thr = threads->new(sub { $SIG{TERM} = sub { $gotsig = 1; CORE::exit(); }; while (1) { sleep 1; } }); sleep 3; $thr->kill('TERM'); sleep 3; ok(!$thr->is_running(), 'Check that thread is no longer running'); ok($gotsig, 'Check that custom signal handler was used'); foreach (threads->list()) { $_->join() if $_->is_joinable; #check before join, in case target system has non-standard/reliable signal behavior } 1; forks-0.34/t/forks08.t0100755000076500000240000000766711405322324012463 0ustar games#!/usr/local/bin/perl -w my @custom_inc; BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; @custom_inc = @INC = '../lib'; } elsif (!grep /blib/, @INC) { chdir 't' if -d 't'; unshift @INC, (@custom_inc = ('../blib/lib', '../blib/arch')); } } BEGIN {delete $ENV{THREADS_DEBUG}} # no debugging during testing! use forks; # must be done _before_ Test::More which loads real threads.pm use forks::shared; diag( <new->reset; } } # Patch Test::Builder to add fork-thread awareness { no warnings 'redefine'; my $_sanity_check_old = \&Test::Builder::_sanity_check; *Test::Builder::_sanity_check = sub { my $self = $_[0]; # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. if( $self->{Original_Pid} != $$ ) { return; } $_sanity_check_old->(@_); }; } use Test::More tests => 11; use strict; use warnings; use Time::HiRes; # Check that main thread waits full 5 seconds after CHLD signal my $t1 = threads->new(sub { sleep 1; }); my $time = sleep 5; $t1->join(); my $time_int = sprintf("%.0f", $time); cmp_ok($time_int, '>=', 5,'check that main thread sleeps full 5 seconds after CHLD signal'); cmp_ok($time_int, '<=', 7,'check that main thread did not sleep too long after CHLD signal'); #clock drift / signal delay tolerance # Check that main thread waits full 5 seconds after CHLD signal $t1 = threads->new(sub { sleep 1; }); $time = Time::HiRes::sleep 5; $t1->join(); $time_int = sprintf("%.0f", $time); cmp_ok($time_int, '>=', 5,'check that main thread sleeps full 5 seconds after CHLD signal'); cmp_ok($time_int, '<=', 7,'check that main thread did not sleep too long after CHLD signal'); #clock drift / signal delay tolerance # Check that main thread waits full 5 seconds after CHLD signal SKIP: { skip('usleep not supported on this platform',2) unless &Time::HiRes::d_usleep && defined(my $t = eval { &Time::HiRes::usleep(0) }) && !$@; $t1 = threads->new(sub { sleep 1; }); $time = &Time::HiRes::usleep(5000000); $t1->join(); $time_int = sprintf("%.0f", $time / 10**6); cmp_ok($time_int, '>=', 5,'check that main thread sleeps full 5 seconds after CHLD signal'); cmp_ok($time_int, '<=', 7,'check that main thread did not sleep too long after CHLD signal'); #clock drift / signal delay tolerance } # Check that main thread waits full 5 seconds after CHLD signal SKIP: { skip('Time::HiRes::nanosleep function not supported on this platform',2) unless &Time::HiRes::d_nanosleep && defined(my $t = eval { &Time::HiRes::nanosleep(0) }) && !$@; $t1 = threads->new(sub { sleep 1; }); $time = &Time::HiRes::nanosleep(5000000000); $t1->join(); $time_int = sprintf("%.0f", ($time / 10**9)); cmp_ok($time_int, '>=', 5,'check that main thread sleeps full 5 seconds after CHLD signal'); cmp_ok($time_int, '<=', 7,'check that main thread did not sleep too long after CHLD signal'); #clock drift / signal delay tolerance } # Check that main thread waits full 5 seconds after CHLD signal my $cnt = 0; $SIG{CHLD} = sub { $cnt++ }; $t1 = threads->new(sub { sleep 1; }); $time = sleep 5; $t1->join(); $time_int = sprintf("%.0f", $time); cmp_ok($time_int, '>=', 5,'check that main thread sleeps full 5 seconds after custom CHLD signal'); cmp_ok($time_int, '<=', 7,'check that main thread did not sleep too long after CHLD signal'); #clock drift / signal delay tolerance cmp_ok($cnt, '>=', 1,'check that custom CHLD signal was called'); 1; forks-0.34/t/forks09.t0100755000076500000240000001126311156544677012473 0ustar games#!/usr/local/bin/perl -w my @custom_inc; BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; @custom_inc = @INC = '../lib'; } elsif (!grep /blib/, @INC) { chdir 't' if -d 't'; unshift @INC, (@custom_inc = ('../blib/lib', '../blib/arch')); } } BEGIN {delete $ENV{THREADS_DEBUG}} # no debugging during testing! use forks; # must be done _before_ Test::More which loads real threads.pm use forks::shared; diag( <new->reset; } } # Patch Test::Builder to add fork-thread awareness { no warnings 'redefine'; my $_sanity_check_old = \&Test::Builder::_sanity_check; *Test::Builder::_sanity_check = sub { my $self = $_[0]; # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. if( $self->{Original_Pid} != $$ ) { return; } $_sanity_check_old->(@_); }; } use Test::More tests => 33; use strict; use warnings; ### Start of Testing ### { my $x = shared_clone(14); ok($x == 14, 'number'); $x = shared_clone('test'); ok($x eq 'test', 'string'); } { my %hsh = ('foo' => 2); eval { my $x = shared_clone(%hsh); }; ok($@ =~ /Usage:/, '1 arg'); threads->create(sub {})->join(); # Hide leaks, etc. } { my $x = 'test'; my $foo :shared = shared_clone($x); ok($foo eq 'test', 'cloned string'); $foo = shared_clone(\$x); ok($$foo eq 'test', 'cloned scalar ref'); threads->create(sub { ok($$foo eq 'test', 'cloned scalar ref in thread'); })->join(); } { my $foo :shared; $foo = shared_clone(\$foo); ok(ref($foo) eq 'REF', 'Circular ref typ'); ok(is_shared($foo) == is_shared($$foo), 'Circular ref'); threads->create(sub { ok(is_shared($foo) == is_shared($$foo), 'Circular ref in thread'); my ($x, $y, $z); $x = \$y; $y = \$z; $z = \$x; $foo = shared_clone($x); })->join(); #TODO: fix to re-load shared REFs before comparison; to be addressed in later release is_shared($$foo); is_shared($$$$$foo); ok(is_shared($$foo) == is_shared($$$$$foo), 'Cloned circular refs from thread'); } { my @ary = (qw/foo bar baz/); my $ary = shared_clone(\@ary); ok($ary->[1] eq 'bar', 'Cloned array'); $ary->[1] = 99; ok($ary->[1] == 99, 'Clone mod'); ok($ary[1] eq 'bar', 'Original array'); threads->create(sub { ok($ary->[1] == 99, 'Clone mod in thread'); $ary[1] = 'bork'; $ary->[1] = 'thread'; })->join(); ok($ary->[1] eq 'thread', 'Clone mod from thread'); ok($ary[1] eq 'bar', 'Original array'); } { my $hsh :shared = shared_clone({'foo' => [qw/foo bar baz/]}); ok(is_shared($hsh), 'Shared hash ref'); ok(is_shared($hsh->{'foo'}), 'Shared hash ref elem'); ok($$hsh{'foo'}[1] eq 'bar', 'Cloned structure'); } { my $obj = \do { my $bork = 99; }; bless($obj, 'Bork'); Internals::SvREADONLY($$obj, 1) if ($] >= 5.008003); my $bork = shared_clone($obj); ok($$bork == 99, 'cloned scalar ref object'); ok(($] < 5.008003) || Internals::SvREADONLY($$bork), 'read-only'); ok(ref($bork) eq 'Bork', 'Object class'); threads->create(sub { ok($$bork == 99, 'cloned scalar ref object in thread'); ok(($] < 5.008003) || Internals::SvREADONLY($$bork), 'read-only'); ok(ref($bork) eq 'Bork', 'Object class'); })->join(); } { my $scalar = 'zip'; my $obj = { 'ary' => [ 1, 'foo', [ 86 ], { 'bar' => [ 'baz' ] } ], 'ref' => \$scalar, }; $obj->{'self'} = $obj; bless($obj, 'Foo'); my $copy :shared; threads->create(sub { $copy = shared_clone($obj); ok(${$copy->{'ref'}} eq 'zip', 'Obj ref in thread'); ok(is_shared($copy) == is_shared($copy->{'self'}), 'Circular ref in cloned obj'); ok(is_shared($copy->{'ary'}->[2]), 'Shared element in cloned obj'); })->join(); ok(ref($copy) eq 'Foo', 'Obj cloned by thread'); ok(${$copy->{'ref'}} eq 'zip', 'Obj ref in thread'); ok(is_shared($copy) == is_shared($copy->{'self'}), 'Circular ref in cloned obj'); ok($copy->{'ary'}->[3]->{'bar'}->[0] eq 'baz', 'Deeply cloned'); ok(ref($copy) eq 'Foo', 'Cloned object class'); } 1; forks-0.34/t/forks10.t0100644000076500000240000000476211156674764012467 0ustar games#!/usr/local/bin/perl -w my @custom_inc; BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; @custom_inc = @INC = '../lib'; } elsif (!grep /blib/, @INC) { chdir 't' if -d 't'; unshift @INC, (@custom_inc = ('../blib/lib', '../blib/arch')); } } BEGIN {delete $ENV{THREADS_DEBUG}} # no debugging during testing! use forks; # must be done _before_ Test::More which loads real threads.pm use forks::shared; diag( <new->reset; } } # Patch Test::Builder to add fork-thread awareness { no warnings 'redefine'; my $_sanity_check_old = \&Test::Builder::_sanity_check; *Test::Builder::_sanity_check = sub { my $self = $_[0]; # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. if( $self->{Original_Pid} != $$ ) { return; } $_sanity_check_old->(@_); }; } package ClassClone; use threads::shared; use vars qw(%OBJ); use Scalar::Util qw(weaken); sub CLONE { $OBJ->{$_}->{cloned} = 1 foreach keys %OBJ; } sub new_href { my $o = bless { new => 1 }; $OBJ{$o} = $o; weaken $OBJ{$o}; $o; } sub new_aref { my $o = bless [5]; $OBJ{$o} = $o; weaken $OBJ{$o}; $o; } sub new_sref { my $o = bless \(my $s = 10); $OBJ{$o} = $o; weaken $OBJ{$o}; $o; } package ClassSkipClone; use threads::shared; sub CLONE_SKIP { 1 } sub new_href { bless { new => 1 } } sub new_aref { bless [5] } sub new_sref { bless \(my $s = 10) } package main; use Test::More tests => 18; use strict; use warnings; sub check_obj { my $obj = shift; my $type = shift; is( ref($obj), $type, "Check that object type is $type" ); ok( defined($obj), "Check that object type is defined" ); } # Check that CLONE_SKIP behaves as expected my %ops = qw/HASH new_href ARRAY new_aref SCALAR new_sref/; while (my ($type, $new) = each %ops) { my $obj = ClassSkipClone->$new(); check_obj($obj, 'ClassSkipClone'); threads->create(sub { check_obj($obj, $type); 1; })->join(); check_obj($obj, 'ClassSkipClone'); } 1; forks-0.34/t/forks20.t0100755000076500000240000000630711126450255012450 0ustar games#!/usr/local/bin/perl -T -w BEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; @INC = '../lib'; } elsif (!grep /blib/, @INC) { chdir 't' if -d 't'; unshift @INC, ('../blib/lib', '../blib/arch'); } } BEGIN {delete $ENV{THREADS_DEBUG}} # no debugging during testing! use forks; # must be done _before_ Test::More which loads real threads.pm use forks::shared; use Config; my ($reason,$tests,$entries); BEGIN { $entries = 25; $tests = 3 + (3 * $entries); eval {require Thread::Queue}; $reason = ''; $reason = 'Thread::Queue not found' unless defined $Thread::Queue::VERSION; $tests = 1 if $reason; } #BEGIN # "Unpatch" Test::More, who internally tries to disable threads BEGIN { no warnings 'redefine'; if ($] < 5.008001) { require forks::shared::global_filter; import forks::shared::global_filter 'Test::Builder'; require Test::Builder; *Test::Builder::share = \&threads::shared::share; *Test::Builder::lock = \&threads::shared::lock; Test::Builder->new->reset; } } # Patch Test::Builder to add fork-thread awareness { no warnings 'redefine'; my $_sanity_check_old = \&Test::Builder::_sanity_check; *Test::Builder::_sanity_check = sub { my $self = $_[0]; # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. if( $self->{Original_Pid} != $$ ) { return; } $_sanity_check_old->(@_); }; } use Test::More tests => $tests; use strict; use warnings; diag( <new; isa_ok( $q,'Thread::Queue', "Check if object has correct type" ); #------------------------------------------------------------------------ # queueing from child thread, dequeuing from main thread threads->new( sub { $q->enqueue( 1..$entries ); } )->join; is( $q->pending,$entries,"Check all $entries entries on queue" ); foreach (1..$entries) { my $value = $q->dequeue; is( $value,$_,"Check whether '$_' gotten from queue in main" ); } #------------------------------------------------------------------------ # queueing from main thread, non-blocking dequeuing from child thread $q = Thread::Queue->new( 1..$entries ); is( $q->pending,$entries,"Check all $entries entries on queue" ); threads->new( sub { foreach (1..$entries) { my $value = $q->dequeue_nb; is( $value,$_,"Check '$_' gotten from queue in child" ); } } )->join; #------------------------------------------------------------------------ # queueing and dequeueing from child threads my $enqueue = threads->new( sub { foreach (1..$entries) { $q->enqueue( $_ ); } } ); my $dequeue = threads->new( sub { foreach (1..$entries) { my $value = $q->dequeue; is( $value,$_,"Check '$_' gotten from queue in other child" ); } } ); $enqueue->join; $dequeue->join; #------------------------------------------------------------------------ } #SKIP 1; forks-0.34/t/forks99.t0100644000076500000240000000173310530016154012455 0ustar games#!/usr/local/bin/perl -w use Test::More; use strict; if (!$ENV{TEST_SIGNATURE}) { plan skip_all => "Set the environment variable TEST_SIGNATURE to enable this test."; } elsif (!eval { require Module::Signature; 1 }) { plan skip_all => "Next time around, consider installing Module::Signature, ". "so you can verify the integrity of this distribution."; } elsif ( !-e 'SIGNATURE' ) { plan skip_all => "SIGNATURE not found"; } elsif ( -s 'SIGNATURE' == 0 ) { plan skip_all => "SIGNATURE file empty"; } elsif (!eval { require Socket; Socket::inet_aton('pgp.mit.edu') }) { plan skip_all => "Cannot connect to the keyserver to check module ". "signature"; } else { plan tests => 1; } my $ret = Module::Signature::verify(); SKIP: { skip "Module::Signature cannot verify", 1 if $ret eq Module::Signature::CANNOT_VERIFY(); cmp_ok $ret, '==', Module::Signature::SIGNATURE_OK(), "Valid signature"; } 1; __END__ forks-0.34/TODO0100755000076500000240000002405711405343362011224 0ustar games***** Future Features / Interface Changes ***** optimizations: - support alternate, faster locking mechanisms (filesystem and/or SysV shmem) - allow for shared memory as transport medium - current alternative is to use BerkeleyDB, e.g. forks::BerkeleyDB - implement more methods using custom filters (to reduce Storable usage) Make thread objects shared in nature, such that their properties may be read across all threads. Will make _handle more reliable, and allow for thread state params to be persisted. Add a method to give the user run-time privilege control over Unix socket file descriptors (for additional security control). Possibly implement TTY wrapper control for Perl debugger, such that user has simpler API functions to call to bind a thread to a TTY. Idea is to integrate debugger TTY control functionality as thread create arguments, to allow for unique tty subroutines to be defined per thread, or unique TTY values to be "bound" to specific threads. Consider interfacing with graphical Perl debugger intefaces, to simplify multi-threaded debugging; managing multiple TTYs, although supported in different terminals (1 per thread), can be conceptually difficult. Considering interface to Devel::PDB. Consider support for Eclipse. Open to suggestions, comments, patches. ***** Issues to Address ***** Need to load internally cached, shared REF values from server, not from first use to insure that values are correctly loaded, to insure they correctly evaluate when used in is_shared(). (TODO temp patch seen in t/forks09.t) Circular references and ref(), Scalar::Util::reftype(), attribute::reftype() don't work well with perltie shared variables. Likely a limitation of how we're using variables in a remote process. May be able to improve on this by overloading all these functions with a forks::shared aware function that contacts remote process when variable is shared to determine what has circular recursion and what doesn't. END { } blocks should be skipped unless they were defined in a thread: eval "END {...}" or module use/require). One idea is to somehow sneak POSIX::_exit(), as long as we are careful to flush buffered sockets before calling it. NOTE: this behavior likely should ONLY occur when in native ithreads mode; I consider END {...} block execution a good thing for all threads that were aware of it otherwise. (Note: better programming practice would be to use DESTROY method whenever possible, but END is important for some modules. Environment variables should be shared among all threads (ithreads behavior). Current working directory should be shared among all threads (ithreads behavior). Note that this may be considered bug in current ithreads implementation. Memory is currently not reclaimed for shared variables that are no longer referenced by any thread. Possible solutions: implement PL_destroyhook; or use STORE for threads::shared objects, and DESTROY for threads, to track shared var _refcnt. DESTROY will be called on shared objects in an exiting thread, even if still referenced in other threads. If can track global _refcnt, could determine refcnt state from server and destroy only when 0. Determine if it is possible to recover all memory from detached threads. Joined threads reclaim all shared memory (very stable memory usage); detached threads currently use a small amount of memory (~200Kb/100K threads) even after they complete. exit() in a thread may allow other threads that were waiting to join that thread to continue before they are terminated (race condition). Join should not return. Add more defensive logic in _join() to prevent hang on join (for processes that have already terminated). May wish to check client socket when join for that thread is requested: if socket exception, then assume client terminated; otherwise, wait for client (regularly checking client socket connection to determine if it has prematurely closed). Perl 5.6 doesn't seem to respond to thread global exit in this case: use forks; threads->new(sub { exit($desired_exit_val);} )->join(); sleep 10; sleep 10; ***** Possible Issues to Address ***** In rare cases, if the main thread dies, the server process doesn't appear to shut down correctly. Sometimes, it appears to use high CPU usage (is stuck in a loop somewhere). It is likely that a socket disconnect is getting a read or write while loop stuck in a loop, and that additional error checking (or non-error occurrence but no change to the amount of data read/written) might help the state of things. Reproducing this one is pretty hard--I can't create the exact conditions yet to manually trigger it. Problem last seen in forks 0.20. Note that this issue may have been squashed in forks 0.21, as most of the socket handling was rewritten in that release. Need to look into why some signals very rarely are not handled by threads (i.e. SIGTERM should cause thread to exit--but thread appears to have ignored signal. Is this a side effect of Perl's safe signal handling mechanism?). The thread does appear to actually get the signal, but sometimes it doesn't seem to completely exit. Problem last seen in forks 0.23, but not seen since forks 0.25, so may be resolved. ***** Miscellaneous Items ***** Update documentation to discuss fault-tolerance (individual thread can't take down the thread group, even with memory faults like segfault). Very helpful for high-availability systems. Consider checking _check_pl_signal_unsafe_flag for any thread signaling behavior, and warn user about (or prevent from using) signals (i.e. deadlock detect, $t->kill). Allow manual disabling of forks.pm signal management (for embedding with other pragmas or interfaces that implement their own signals management, such as mod_perl via Apache::forks). Need a way to keep deserialized shared variable references consistent between lookups, e.g. my $shared :shared = &share({}); $$shared{'foo'} = 'bar'; my $str1 = "$shared"; my $str2 = "$shared"; ok($str1 eq $str2, 'stringify'); This is a side-effect of Storable, which reconstitutes a new tied hash each time FETCH returns a shared variable. This might be solved with overload.pm, although documentation indicates that it may not work with Storable since we're masking the master package in a different file (Storable uses XS load_module, which tries to load real threads/shared.pm even though %INC is populated). (I wonder if it's possible to fake out load_module?) Thus, maybe we can implement a thread-local reference cache for all shared variables (dynamically populated as they are FETCHed), which returns the thread-local copy instead of the server copy. (Same idea as forks::BerkeleyDB, but caching the server copy instead.) Benefit to this method is that ref() and refaddr() will return the same results, although won't return the same value as is_shared() unless we change this to use the same logic. UPDATE: we need to get away from the caching mechanism, or somehow have logic that resolves REF types (before or in) the shared server such that it returns a shared variable to the code. The code itself should be able to know the following: 1. when a REF is a shared variable 2. when a REF has changed in the shared process, we need to make sure all child threads that have a reference to it are correctly updated. Enable custom concurrent lock interface to support optimized locking mechanisms; specifically, SysV semaphores, filesystem (+alarm/ALRM), or other possibilities. Add additional tests to rigorously test tied handle (for shared var) behavior. Test delete with single, hash slice, and array slice elements. Cache signal names from Config.pm for higher performance (avoid tied access)? Begin adding some sort of CLONE forks.pm compatibility framework to insure that modules that implement non-forks.pm CLONE methods are supported. Currently, DBI is the only known module that may need a CLONE patch, and this is only to suppress annoying warning for resources that are closed (or is this something that actually needs to be fixed in DBI?) Signals sent to main thread can propagate to all threads. We need to prevent this from happening, if possible, to replicate threads.pm behavior. This may be due to signal being sent to a process group (so it may not be blockable). Add recursive lock tests with cond_* (to test that recursive locks are correctly acquired and released). Add tests to validate that storing CODE refs in shared variables works. Add documentation explaining that forks installs a SIGCHLD handler by default, and that system calls in your user code may be interrupted by this handler at any time (threads exiting), depending on the system call and if your kernel auto-continues the system call after handling the signal. NOTE: There still appears to be an issue with the last value of $! not being cleared and EINTR still being returned on the next accept() vall. Setting $! to undef before calling the system call appears to clear the issue. This is system behavior outside of forks module that needs more research to resolve. A few suggestions if this is an issue: 1. Check if $! == POSIX::EINTR() if your system call returns undef. If so, manually re-enter into (call again) the system call, like: while((my $conn = $server->accept) || $! == EINTR) { next if $! == EINTR; ... } This is the most portable solution. 2. Localize $SIG{CHLD} = 'IGNORE' when performing your interruptible (non-reentrant) system call. For example: my $conn; my $loop = 1; while($loop) { { local $SIG{CHLD} = 'IGNORE'; $conn = $server->accept; next if $! == EINTR; last unless $conn; } ... } This is a more verbose but acceptable solution. 3. Set $SIG{CHLD} = 'IGNORE' after loading the forks module. This is the simplest solution as it applies globally to all system calls, but be warned that this may cause the exit value of your script to be ignored (returns -1) depending on your kernel behavior. You can always check your kernel behavior by executing the following at a shell command line: perl -e '$SIG{CHLD} = "IGNORE"; exit(42);'; echo "Expected 42. Got $?" forks-0.34/VERSION0100755000076500000240000000000511141756427011576 0ustar games0.29