IPC-Shareable-1.19/000755 000765 000024 00000000000 15222770210 014232 5ustar00stevestaff000000 000000 IPC-Shareable-1.19/Shareable.xs000644 000765 000024 00000001551 15204067722 016505 0ustar00stevestaff000000 000000 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" MODULE = IPC::Shareable PACKAGE = IPC::Shareable PROTOTYPES: DISABLE # XS version of _is_child() SV * _is_child_xs(sv) SV *sv CODE: if (!sv || !SvROK(sv)) { RETVAL = &PL_sv_undef; } else { SV *rv = SvRV(sv); MAGIC *mg = NULL; switch (SvTYPE(rv)) { case SVt_PVHV: case SVt_PVAV: mg = mg_find(rv, PERL_MAGIC_tied); break; case SVt_PVMG: mg = mg_find(rv, PERL_MAGIC_tiedscalar); break; default: break; } if (mg && mg->mg_obj && sv_derived_from(mg->mg_obj, "IPC::Shareable")) { RETVAL = SvREFCNT_inc(mg->mg_obj); } else { RETVAL = &PL_sv_undef; } } OUTPUT: RETVAL IPC-Shareable-1.19/DISCLAIMER000644 000765 000024 00000002324 14210441431 015566 0ustar00stevestaff000000 000000 NO WARRANTY BECAUSE THE SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. IPC-Shareable-1.19/Changes000644 000765 000024 00000072502 15222767331 015545 0ustar00stevestaff000000 000000 Revision history for Perl extension IPC::Shareable. 1.19 2026-07-06 - Fix mass CPAN tester FAILs on OpenBSD (29 of 32 reports for 1.18): the smoker host's 10 SysV semaphore-set slots (kern.seminfo.semmni=10) were pre-exhausted by stale sets leaked from previously crashed runs, so nearly every tie died with semget ENOSPC ("Could not create semaphore set: No space left on device"), and each failing run leaked further resources - _tie(): an IPC_PRIVATE segment is now removed when semaphore-set creation (or the initial lock) fails. shmget(IPC_PRIVATE) always creates a fresh segment regardless of the 'create' attribute, and a private segment is unreachable by key after the croak, so it leaked invisibly (~4 segments per failed suite run on the wedged smoker) - clean_up_testing(): added a second pass that reclaims orphaned testing-tagged semaphore sets whose segment is already gone; these pin a SEMMNI slot forever and were invisible to the ipcs -m based scan. New regression test t/82-stale-ipc-reclaim.t - t/00-base.t: reclaim a stale async_tests pair by name (pre-1.18 leftovers have 4-slot, unmarked semaphore sets that clean_up_testing() cannot prove ownership of), and make the end-of-file segment count adaptive for the attach case, fixing the off-by-one failure when a stale async_tests segment existed - t/IPCShareableTest.pm: added free_sem_sets() and require_free_sem_sets($n) (default 8); the 26 tie-heavy test files that FAILed on the wedged smoker now skip_all cleanly when the host lacks free semaphore sets, instead of croaking mid-run and leaking - t/24-lock_fork_blocking.t: replace the fixed 0.28s lock-wait floor with one computed from when the parent actually issued the lock call; on loaded smokers the parent could be descheduled past the child's 0.3s hold window, failing with waits of 0.000s (seen on Linux testers) - t/19-lock_recursive.t: hold locks until the probing process signals its LOCK_NB probes are done (second pipe), instead of for a fixed 0.3s/0.5s window; the FreeBSD 15 tester FAILs for 1.18 ("3-level: level-2 grandchild LOCK_EX|LOCK_NB blocked") were this race - t/20-lock_operation.t: replace the create-3-probe-sets resource check with require_free_sem_sets(); the old probe's skip path still exited 255 on resource-starved smokers, and consumed scarce sets to probe - sysv_info(): recognize MidnightBSD and NetBSD (kern.ipc sysctls, both ':' and '=' output separators); NetBSD's semmni also defaults to 10, so the test suite's free-set guard now activates there too 1.18 2026-06-08 - Fix intermittent CPAN failures under parallel smokers, which assumed exclusive use of System V IPC. Added t/IPCShareableTest.pm (unique_glue, assert_clean, assert_clean_process, live_seg_count) and moved the fork tests (t/18, 19, 24, 26, 28, 32, 44) to per-run keys with run-scoped cleanup checks - t/26-ipcav.t and t/38-lsync.t: replace the racy SIGALRM/sleep handshake (lost-wakeup; could hang under smokers or emulation) with a two-pipe handshake - t/47-seg_size.t: skip the "size > max RAM must croak" check on 32-bit size_t, where the size wraps to an allocatable value and the tie succeeds - Replace global seg_count()/sem_count() cleanup checks with a process-scoped assert_clean_process(); the suite now passes under `prove -j4`. t/00-base and t/99-end keep a global count check, serial-only - Re-key ~30 more tests with per-run keys so concurrent runs can't collide. t/06-key stays serial-only (it pins the key-generation algorithm) - clean_up_testing() now removes only segments the caller created or whose creator has exited, leaving another live process's segments alone -- safe under `prove -j` and concurrent smokers - Tied SCALARs holding a plain (non-reference) value now store it verbatim rather than JSON/Storable-wrapping it; references still share their structure as before. (Numbers read back in string form, but still compare equal numerically) - Fix a shared-memory segment leak when a tie created its segment but failed to set up its semaphore (eg. ENOSPC) or acquire its initial lock: the segment (and any semaphore set we created) is now removed before croaking, which still reports the underlying cause - Make the suite resilient on hosts with a small semaphore budget (eg. OpenBSD, semmni=10): t/94 and t/95 release their IPC between steps there. Adds sem_set_limit/low_sem_resources/relieve_ipc_pressure helpers, plus t/96 and t/97 - Tolerate a semaphore set removed by another process (EINVAL on the next operation), the cause of intermittent CPAN-tester failures on heavily parallel smokers. _write_permitted() now skips its advisory lock check when getval() returns undef (it had been emitting "uninitialized value in numeric gt" warnings), and unlock() warns once and continues rather than croaking "Could not release semaphore lock". Adds t/81-sem-removed-under-lock.t - Finish migrating the forked tests off the lost-wakeup SIGALRM/sleep handshake (which could hang a smoker or desync the processes): t/03, 18, 28, 30, 36, 66 and 85 now use a shared pipe-barrier helper (barrier_new/barrier_wait/barrier_release in t/IPCShareableTest.pm) 1.17 2026-05-31 - POD enhancements regarding testing_set() and clean_up_testing() - Test VM enhancements (now allows Async::Event::Interval to piggy back them) - sysv_info() now reports semaphore limits (semmni, semmns, semmsl, semopm) alongside the shm* keys on FreeBSD, Linux, macOS, and OpenBSD; lets tests size themselves to the platform's kern.ipc.semmni budget - FreeBSD CI: pre-test IPC cleanup widened to non-system users and root; optional IPC_DEBUG_DELTAS=1 enables per-file leak detection - Fix CPAN test failures on Mock::Sub 1.08 (t/20, t/60, t/68; t/85 had the same latent issue): those tests mocked subs with 'return_value => undef', but Mock::Sub 1.08 returns the sub's call args (not undef) in that case, so the croak/warn-on-undef paths under test never fired. Replaced those mocks with block-scoped local typeglob overrides that return undef directly, and raised the Mock::Sub build prereq to 1.09 1.16 2026-05-27 - POD: Promoted the signal handling note into its own section under DESTRUCTION - Fully implement Dragonfly BSD unit test VM infrastructure - Fix shmid_ds unpack for Dragonfly BSD - Prevent macOS extended attributes from leaking into dist tarballs 1.15 2026-05-26 - Refactor how we initialize $VERSION. It's no longer in a BEGIN block. That broke Dist::Mgr - Fixes #60: Fix FETCH deadlock when inner child re-decode acquires SH lock against LOCK_EX cascade held by _lock_children - Fix OpenBSD 64-bit shmid_ds binary layout (verified via offsetof on 7.4): segsz is int (4B not 8B), nattch is short (2B), and struct has nanosecond fields between time_t values. Updated t/80-SharedMem.t synthetic test and shm_segments() segsz extraction to match. - Added OpenBSD test VM infrastructure - t/20-lock_operation.t: probe for adequate semaphore resources before running, skip gracefully on low-limit platforms (OpenBSD semmni=10). Added periodic _end() cleanup calls so peak semaphore usage stays within the default limit on OpenBSD. - Added 'testing' flag; allows bulk cleanup of leaked segs/sems from a previous test run. This was implemented in this distribution's unit test suite - Fix t/80-SharedMem.t: skip 64-bit tests on 32-bit Perl where the 'q' pack template is unavailable (Raspian OS specifically) 1.14 2026-05-22 - Modify remove() to properly catch a non "0 but true" case when trying to destroy segments and semaphores so warnings are displayed properly - remove() now leaves the global and process registers intact if the destroy operation fails - Rename _mg_tie() to _magic_tie() - Rename _is_kid() to _is_child() - In IPC::SharedMem, removed leading underscore from object attributes - Parameter list in IPC::SharedMem::new() is now in the form of a hash - Code refactoring in IPC::SharedMem - Add POD for IPC::SharedMem - SharedMem::remove() now returns 1 on '0 but true' and 0 otherwise that was preventing matches from happening, and broke JSON - ipcs() now ignores lines that don't include an actual key - Add data() method to SharedMem. This strips off the NULL pad bytes from shmread() - Added key_hex() to SharedMem. Will allow for easier troubleshooting when using ipcs (closes #32) - Added SharedMem::stat(); returns a new object that contains the related info about the actual shared memory segment - Fixes #49; Logic error from old implementation of JSON - Fixes #47; Clean up broken code in old _decode_json() - Fixes #41; JSON serializer not handling nested data structures properly - Closes #52; Add tests and POD for SharedMem::stat struct methods - Added SharedMem::stats(), return an href of all segment stats - Closes #48; All tests now run unconditionally; there is no more CI_TESTING flag required - Greatly simplify the FIRSTKEY and NEXTKEY shared hash ops; removed the _iterating flag complexity and replaced it with an _hkey_list instead - Fixes #38; Fixed issue where the global_register was not being populated if a data access hadn't happened yet, causing leaked segments upon cleanup. This fix eliminated the weird 'Dumper' hack - Add new scripts/flush_ipc.sh script that cleans out all segments and semaphores from the system for the current user - Closes #28; Add link to Script::Singleton in singleton() POD - Closes #24; lock() now allows a cref parameter. If a LOCK_EX lock can be acquired, we will set the lock, execute the subroutine, then release the lock - 'tidy' attribute now defaults to true - All unit tests do a check for leaked segments and semaphores at their conclusion. Also, when running 'make test' it compares the numbers before and after and doubly makes sure there are no leaks - Closes #51; Better document that the 'size' attribute is for each segment, and not the overall size of all the data. Also emphasize that each nested data structure requires an additional segment, they aren't all stashed into a single one - Added uuid(), sets an internal UUID for each tied object (primarily used for troubleshooting) - Fixes #50; Added enforced locking, with optional warning - Correct five areas in clean/delete routines where segments may have been able to leak - Removed redundant _global_register checks in STORE, FETCH, PUSH; _tie() already registers unconditionally - Add ref() check before _is_child(); skips the function call reftype() entirely for plain scalar values in FETCH, CLEAR, and DELETE - Add ref() check before _need_tie(); same pattern in all three STORE branches - _type_int numeric dispatch; string eq comparisons on every operation replaced with == against integer constants in STORE, FETCH, and CLEAR - Major POD enhancements/cleanup - Renamed ipcs() to seg_count() as it's far more explanatory - Add new method sysv_info() which if the system provides it, retrieves all information related to the SYSV infrastructure (limits etc) - Closes #45; We now accept a hex-based value as the key - Added shm_segments(); fetches raw data about all segments that had been created by this distribution - Added unknown_segments(); returns an aref of all segment keys (in hex string format) for segments we've created but are no longer registered to any known process - Closes #39; remove() now accepts a key, and can remove the segment and semaphores related to that key, even if it isn't related to this distribution - Updated CI so we get a test run on an i386 Ubuntu container to test 32-bit platforms - Fix issue when using JSON serializer where it wasn't properly handling scalar references properly (eg. creating a tie with a hashref) - Enhanced much of the test suite to test both Storable and JSON serializers - Much work in order to add provisions so that shm counting and tracking works on FreeBSD - Add FreeBSD VM config and unit test runner in ci/ dir - Removed the archaic _debug() and _trace functions - Enhanced 'protected' segments; we now use a semaphore to mark a segment as protected (SEM_PROTECTED), and all processes that load this segment will inherit the protected status - Add sem_map(); outputs a text representation of the segment/semaphore mappings - Added consistent naming for all four semaphores: SEM_EXISTS, SEM_READERS, SEM_WRITERS, and SEM_PROTECTED - Default serializer now JSON; Added check for backwards compatibility that if JSON _decode() fails, we then attempt a Storable _thaw() - Added sem_count(); behaves like seg_count() but for semaphores. Also updated tests to ensure no straggling semaphores are left behind - All LOCK_EX and LOCK_SH locks are now applied to all child segments when the lock is first instantiated on the tied object. Both of them are rolled out in reverse order from the lowest-level child upwards when the lock is released - New attributes for updated locking mechanisms: enforced_write_locking, enforced_read_locking, violated_write_lock_warn and violated_read_lock_warn. All enabled by default - Fixes #11; On non-English locales on perl 5.20 and below, checking $! for strings in certain cases was failing and sending code down the wrong path. The fix was to replace the comparisons with $!{ERRNO_CONST} variables instead (eg. $!{EEXIST}, $!{ENOMEM}, $!{ENOSPC}) which are locale-independent - Add Solaris (including OmniOS/illumos) support for shm_segments(), seg_map(), and SharedMem stat()/stats() methods by providing Solaris-specific shmid_ds unpack templates - Add explicit use Errno so that $!{ENOMEM} and $!{EEXIST} checks work reliably on all platforms (Solaris Perl builds did not populate these keys in the %! tied hash without the module loaded) - Complete VM unit testing framework with scripts and README for FreeBSD, Linux i386 and Solaris (32 and 64 bit) - Replace regex-based null-byte stripping in SharedMem::data() with more efficient index+substr - SharedMem::stats() now calls stat() once and reuses it, avoiding 11 redundant shmctl(IPC_STAT) syscalls - _encode_json_prepare() now short-circuits for structures with no IPC::Shareable child refs, avoiding a full hash/array copy on every encode - _decode_json_restore() hoists ref($prev) checks outside hot loop - Added XS implementation of _is_child() for faster child-knot detection; falls back to pure Perl _is_child_pp() if the compiled XS can't be loaded. The XS function _is_child_xs inspects SV magic directly in C, avoiding Scalar::Util::reftype, tied(), and ref() calls - Added t/75-is_child_xs.t to test both XS and pure-Perl _is_child paths - Added IPC_SHAREABLE_NO_XS env var to force pure-Perl mode for verifying operation on systems without a C compiler - Eliminated redundant second ipcs -m shell-out in seg_map(); get id mapping from shm_segments() result instead - Replaced all backtick shell-outs with open('-|', @cmd) pipe-open to bypass /bin/sh and halve the fork count - Rewrote _lock_children() from recursive to iterative (manual stack) to eliminate Perl call-stack overhead on deeply nested structures; simplified interface returns an arrayref instead of passing accumulator/seen refs - Fix STORE child-segment leak: old child references were silently discarded without removing shm segments/semaphores. STORE now calls _remove_child() before overwriting. Extracted the common pattern into _remove_child() to deduplicate across DELETE, CLEAR, and STORE. - Remove the 'tidy' attribute and _reset_segment() internals. The STORE fix made _reset_segment() a no-op that only produced double-removal warnings. - Fix t/25-fetch_read_warn.t pipe synchronization so the parent blocks until the child confirms LOCK_EX, instead of a blind sleep - shm_segments() now probes the 14-byte 'IPC::Shareable' tag before pulling the full segment into Perl, avoiding gigabyte allocations for foreign segs - Drop unconditional use-time srand(); _shm_key_rand collisions are already caught by the IPC_EXCL re-check loop, so reseeding callers' RNG is needless - Remove redundant Data::Dumper imports from Shareable.pm and SharedMem.pm - Fix _shm_key() off-by-one: overflow-correction now triggers on crc32 == MAX_KEY_INT_SIZE, making the post-subtraction key==0 croak actually reachable - Test coverage additions: unknown_segments() via fork+exit, sysv_info() on Solaris, JSON->Storable carp format, both write-lock flags disabled, _shm_key() key==0 croak (Mock::Sub on crc32), IPC_PRIVATE + JSON nested tie, STORE scalar-ref over previous \$undef - Fix t/73-internal.t cross-version: qr// reftype differs between 5.10 and 5.12+, so use a CODE ref to exercise the _encode_json_prepare fallthrough - Bump prereq of Test::More to 0.98 due to 5.10.1 using 0.94 by default 1.13 2022-10-11 - In singleton(), do a check whether class was sent in. There was a shifting issue if called with IPC::Shareable::singleton() as opposed to IPC::Shareable->singleton() - When an exclusive collision occurs and both 'graceful' and 'warn' are set, the warning thrown now includes the segment/semaphore key in use. This makes it easier to clean things up with 'ipcrm' 1.12 2022-03-13 - Add tests in t/07-new.t to test how using tied() against a dereferenced variable returned from new() allows access to the underlying IPC::Shareable object - Reworked how spawn() and unspawn() manage things internally - POD updates, fixes and clarifications - Removed spawn() and unspawn(). There's really no need for these as one can simply create but not destroy 1.11 2022-03-07 - Fix certain tests so they don't throw if we bail early 1.10 2022-03-07 - Fix issue where if segments were created underneath of a parent by an external process other than the process that created the parent, the global register wasn't being updated, therefore those segments weren't being removed when calling clean_up_all() - All test files now check number of segments before and after the entire script has run, verifying that all segments were cleaned up ok - The test suite itself in its entirety makes sure that all segments created during the suite run are cleaned up properly - Added CI_TESTING=1 to coverage CI tests 1.09 2022-03-06 - Made 81-fork_dup_rand_keys.t developer only (but still need to figure out why it only fails on FreeBSD) 1.08 2022-03-04 - Added 'protected' option and clean_up_protected(). If set, the cleanup methods, nor the automatic 'destroy' functionality will remove the segment the option was set in, nor any children created underneath of it. A call to clean_up_protected() is required to remove them - Updated attribute tests to include all available options - _shm_key_rand() now checks EXCLUSIVE_CHECK_LIMIT times to find a key for a free segment. It croaks if not - Added _shm_key_rand_int() so we can mock it to test the dup random key checks - Added build prereq of Mock::Sub to test the random key function 1.07 2022-03-04 - When running in forked environments, _shm_key_rand() was consistently returning the same 'random' key to each forked process. We've fixed this issue, and added tests for it (fixed by adding a call to srand() before rand) - Move $SIG{CHLD} handlers to spawn() and unspawn() instead of having them global (fixes #15) - t/65-seg_size.t fails on 32-bit perls; Add a check and bail if we're on a perl < 64-bit (fixes #14) 1.06 2021-09-08 - Fix significant bug where at least on MacOS, if we generated a CRC of a key that was greater than 0x80000000, it would round down the key to that number exactly, causing duplicates, and incorrect segment access - Added new() method, returns a reference (default hash) without having to do the tie() directly - Fix issue in JSON decoder where an empty JSON string may have caused decode failure - Modify t/65-seg_size.t beyond RAM max test to cover varying error messages on differing OSs - Renamed t/67-out_of_memory.t as the tests are related to exhausting SHM slots, not RAM 1.05 2021-07-16 - Bump prereq version of Test::SharedFork to 0.35 - Added ability to use JSON as the serializer - Added ipcs() - Added test to ensure we croak if data size is greater than segment size - Added 'tidy' attribute, removes unneeded nested structure segments - In SharedMem, added _key attribute, and added set/get methods - Changed key generation from using padding, pack and unpack to using String::CRC32's crc32(), which allows arbitrary, unpadded strings - Added attributes() allows fetching one, or all of the object's atttributes - Added 'limit' attribute, by setting false, allows a user to set a segment size larger than our internal 1GB default - Cleaned up exception throwing (particularly if seg size eats up all memory, we throw an appropriate message) - Display proper exception if we try to exhaust all available shared memory segments (fixes #3) 1.04 2021-06-28 - Skip unspawn tests for perls with -Duselongdouble, as Storable is not compatible storing/retrieving such numbers (closes #5) 1.03 2021-06-25 - Add newline to singleton() warn so that it doesn't print out trace info 1.02 2021-06-25 - Remove erroneous listing from MANIFEST - Work around issue in t/65-seg_size.t where MacOS and FreeBSD don't have the -i flag to ipcs (thanks for the PR, Roland Walker!) - Added singleton(), ensures that only a single instance of a script can run at any given time - Added tests to ensure we croak() if create is not set and the segment doesn't yet exist - Fix POD issue where we stated exclusive returns undef instead of croaking (fixes #10) - Change 'perl' shell call to $^X in t/71-unspawn.t (fixes #6) 1.01 2021-06-24 - Added 'graceful' flag option. With exclusive, if a second process attempts to tie an exclusive segment, we exit gracefully instead of croaking 1.00 2021-06-09 - Project adopted by Steve Bertrand - Added global_register() and process_register() to return the registries of active segments and semaphores - Added seg() and sem() methods, returns the structure of a shared memory segment and a sempahore respectively - Added initial "persist" hash variables. Separate processes (even multiple files in multiple windows) can share a variable, and it'll remain available even after all processes exit. The variable will be re-attached if the same shared segment key is used in subsequent runs - Reversed order of Changes file - Removed trace() and debug() code for ease of reading - Improved exception/error messages, added exception testing, reduced and minimized the number of exceptions actually uncaught - Significant POD cleanup - 100% rewrite of all test files, and added a slew of new ones, all using Test::More - Add build requirement of Test::SharedFork to handle the out of sequence fork() tests in t/35-clean.t and t/30-lock_operations - Major POD updates - Added tests to prove that RT 123057 isn't really an issue (ie. segment size parameter works correctly) 0.61 Mon Oct 8 00:27:39 2012 - Added patch from Frank Lichtenheld fixing IPC::Shareable's dependence on the presence of a perl bug which is no longer present in perl >= 5.10 - Fixed bug reported by Dan Harbin where the FETCH operation on a tie()d string containing HASH, ARRAY, or SCALAR fails because it was using the stringification of the data to determine what kind of reference it was. Now using Scalar::Util::reftype - Added missing dependency on IPC::Semaphore to Makefile.PL (reported by Adrian Issott) - Added a 'sleep 1' in a test that was hanging on certain systems due (possibly) to two alarm signals coming too quickly to the child process. From Ton Voon. 0.60 Mon Mar 5 15:20:18 EST 2001 - Lee Lindley (lee.lindley@bigfoot.com) added the _was_changed optimization, improved the locking functionality, fixed numerous bugs, and generally cleaned things up; thanks. - Removed support for "no" as a false value in arguments; thanks to Dave Rolsky 0.54 Mon Jan 8 11:52:28 EST 2001 - Fix to allow IPC::Shareable to work with 1.0.* versions of Storable 0.53 Tue Nov 14 00:33:35 EST 2000 - Fixed race condition in test suite causing intermitent failures. - Better checking for success of calls to Storable::thaw(); thanks to Raphael Manfredi . 0.52 Thu Sep 14 12:30:17 EDT 2000 - Now STORE, PUSH, POP, etc all call _thaw() before doing their business. - Refined SIGALRM handlers in test scripts - Fixed concurrency issues affecting tied arrays and hashes; thanks to thanks to Robert Emmery , Terry Ewing , Tim Fries , and Joe Thomas . - Doc fixes thanks to Paul Makepeace 0.51 Fri May 5 23:47:06 EDT 2000 - Fixed bug that would cause IPC::Shareable::BUF_SIZ to be ignored; thanks to Robert Emmery and Mohammed J. Kabir for reporting. - Stopped tests from leaking shm segments - Added test of argument parsing - doc fixes 0.50 Tue Mar 21 11:56:32 EST 2000 - Complete rewrite incorporating the following changes. - Requires 5.00503. This allowed the module to get rid of the global cache for shared memory segments; each Shareable object now carries around its own data. - 5.00503 also allowed tied arrays to be implemented - Shared memory segments can no longer be of infinite length thereby reducing the amount of code in the module by a factor of 2. - Uses IPC::Shareable::SharedMem class for accessing shared memory. - Uses IPC::Semaphore module for accessing semaphores. - Completely revisited the way references are dealed with: all referenced thingies are now automagically tied to shared memory. - Constants now imported from IPC::SysV; Shareable.xs is gone - Rewrote test suite and moved into t subdirectory - Updated man page 0.30 Mon Jan 19 11:13:41 EST 1998 - Added SEM_UNDO to semop() calls; Maurice Aubrey. - Fixed some bugs in the locking code; Maurice Aubrey. - Made calls to debug() conditional for efficency; Maurice Aubrey. - Fixed a signal handler in test.pl; Maurice Aubrey. 0.29 Mon Jan 12 13:49:42 EST 1998 - $MAXVER patch for when the version semaphore reaches its limit and rolls back over to 0; Maurice Aubrey . - patch to quieten things down under -w; Doug MacEachern 0.28 Wed Oct 22 14:59:08 EDT 1997 - cleaned up the way thingys are magically tied; Ben Sugars. - moved many subroutines so that they are auto-loaded; Ben Sugars. - updated man page; Ben Sugars. 0.26 Mon Oct 20 10:06:43 EDT 1997 - fixed bug regarding assigning a reference to an empty hash to a tied variable. Thanks to Jason Stevens. 0.25 Tue Oct 7 14:41:49 EDT 1997 - added more checking of sem*() and shm*() return values; Michael Stevens and Ben Sugars. - added shlock and shunlock; Ben Sugars. - fixed bug that would cause modifications of magically referenced thingys to fail. Thanks to Maurice Aubrey 0.20 Thu Aug 28 15:13:46 EDT 1997 - added ability to magically create ties to implicitly referenced thingys; Ben Sugars. 0.18 Thu Aug 28 09:12:30 EDT 1997 - fixed garbage collection bug; Ben Sugars. Thanks to Michael Stevens for the patch. 0.17 Wed Aug 27 15:57:11 EDT 1997 - fixed some bugs in &parse_argument_hash; Ben Sugars. 0.16 Mon Aug 11 16:10:54 EDT 1997 - new shared memory segments now initialized with null values; Ben Sugars. 0.15 Fri Aug 8 15:45:29 EDT 1997 - implemented locking using semaphores; Ben Sugars. 0.12 Thu Aug 7 14:47:42 EDT 1997 - various bug fixes; Ben Sugars. 0.11 Wed Aug 6 10:14:49 EDT 1997 - initial implementation of semaphores for versioning and caching; Ben Sugars. 0.10 Fri Aug 1 13:32:52 EDT 1997 - can now tie both scalars and hashes of arbitrary length; Ben Sugars. 0.05 Wed Jul 30 15:02:31 EDT 1997 - scalars can now be tied; Ben Sugars. 0.01 Wed Jul 30 09:00:53 1997 - original version; created by h2xs 1.18. IPC-Shareable-1.19/MANIFEST000644 000765 000024 00000003135 15222770210 015365 0ustar00stevestaff000000 000000 Changes COPYING CREDITS DISCLAIMER 'docs/Shared Memory Configuration.txt' lib/IPC/Shareable.pm lib/IPC/Shareable/SharedMem.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP Shareable.xs t/00-base.t t/02-create.t t/03-new.t t/04-new_tied_obj.t t/05-shm_stat.t t/06-key.t t/10-sv.t t/11-av.t t/12-hv.t t/14-attributes.t t/16-ref.t t/18-fork_ipc.t t/19-lock_recursive.t t/20-lock_operation.t t/21-lock_coderef.t t/22-lock_semaphore.t t/23-lock_sh_enforcement.t t/24-lock_fork_blocking.t t/25-fetch_nested_lock.t t/26-ipcav.t t/27-fetch_read_warn.t t/28-ipchv.t t/30-ipcref.t t/32-obj.t t/36-ipcobj.t t/38-lsync.t t/40-tied.t t/42-seg_sem.t t/44-nested_segs_overwrite.t t/45-private_json_nested.t t/47-seg_size.t t/48-size_exceeded.t t/49-exhaust_shm_slots.t t/52-graceful.t t/54-singleton.t t/55-singleton_warn.t t/56-singleton_class.t t/60-exceptions.t t/61-json_fork_dup_rand_keys.t t/62-fork_dup_rand_keys.t t/63-sig_child_ignore.t t/65-clean_protected.t t/66-protected_persist.t t/67-storable_fallback.t t/68-encode_fail.t t/69-testing_flag.t t/70-global_register.t t/71-sysv_info.t t/72-shm_segments.t t/73-internal.t t/74-seg_map.t t/75-is_child_xs.t t/76-sem-resources.t t/77-scalar-verbatim.t t/78-scalar-verbatim-edge.t t/79-sem-create-orphan.t t/80-SharedMem.t t/81-sem-removed-under-lock.t t/82-stale-ipc-reclaim.t t/85-clean.t t/86-exports.t t/90-pod_coverage.t t/91-pod_linkcheck.t t/92-pod.t t/93-manifest.t t/99-end.t t/IPCShareableTest.pm META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) IPC-Shareable-1.19/docs/000755 000765 000024 00000000000 15222770207 015170 5ustar00stevestaff000000 000000 IPC-Shareable-1.19/t/000755 000765 000024 00000000000 15222770207 014503 5ustar00stevestaff000000 000000 IPC-Shareable-1.19/PaxHeader/COPYING000644 000765 000024 00000035074 14210441431 017243 xustar00stevestaff000000 000000 30 mtime=1646412569.410309341 127 LIBARCHIVE.xattr.com.apple.metadata:kMDItemTextContentLanguage=YnBsaXN0MDBSZW4IAAAAAAAAAQEAAAAAAAAAAQAAAAAAAAAAAAAAAAAAAAs 108 SCHILY.xattr.com.apple.metadata:kMDItemTextContentLanguage=bplist00Ren 123 LIBARCHIVE.xattr.com.apple.metadata:kMDItemKeyphraseVersion=YnBsaXN0MDAQDAgAAAAAAAABAQAAAAAAAAABAAAAAAAAAAAAAAAAAAAACg 104 SCHILY.xattr.com.apple.metadata:kMDItemKeyphraseVersion=bplist00  5421 LIBARCHIVE.xattr.com.apple.metadata:kMDItemKeyphraseLabels=YnBsaXN0MDCvEKcBAgMEBQYHCAkKCwwNDg8QERITFBUWFxgZGhscHR4fICEiIyQlJicoKSorLC0uLzAxMjM0NTY3ODk6Ozw9Pj9AQUJDREVGR0hJSktMTU5PUFFSU1RVVldYWVpbXF1eX2BhYmNkZWZnaGlqa2xtbm9wcXJzdHV2d3h5ent8fX5/gIGCg4SFhoeIiYqLjI2Oj5CRkpOUlZaXmJmam5ydnp+goaKjpKWmp1pwYXBlciBtYWlsXxAQY29weXJpZ2h0IGhvbGRlcl8QEWNvcHlyaWdodCBob2xkZXJzXxAPc29sZSBwdXJwb3NlIG9mXxAZb3JpZ2luYWwgY29weXJpZ2h0IGhvbGRlclxzaG9ydCBub3RpY2VfEBFkaXN0cmlidXRlIGNvcGllc18QGmRpc3RyaWJ1dGUgdmVyYmF0aW0gY29waWVzXxAQb3BlcmF0aW5nIHN5c3RlbV8QEGRlcml2YXRpdmUgd29ya3NeY291cnQganVkZ21lbnRfECJkaXN0cmlidXRlIGNvcGllcyBvZiBmcmVlIHNvZnR3YXJlXxAWd2lkZSByYW5nZSBvZiBzb2Z0d2FyZV8QFGV2ZXJ5b25lIHVuZGVyc3RhbmRzXxAScmVxdWlyZW1lbnRzIGFwcGx5XxAPcGF0ZW50IGxpY2Vuc2VzXxAWZ2VuZXJvdXMgY29udHJpYnV0aW9uc18QD2Z1bGwgY29tcGxpYW5jZV8QE3JlbmRlcmVkIGluYWNjdXJhdGVbdGhpcmQgcGFydHlfECFmcmVlIHNvZnR3YXJlIGRpc3RyaWJ1dGlvbiBzeXN0ZW1fEBJjZXJ0YWluIGNvbmRpdGlvbnNfEBBtYWpvciBjb21wb25lbnRzW3NvdXJjZSBjb2RlXxAVbWFjaGluZS1yZWFkYWJsZSBjb3B5XxAtZXhwbGljaXQgZ2VvZ3JhcGhpY2FsIGRpc3RyaWJ1dGlvbiBsaW1pdGF0aW9uXXRoaXJkIHBhcnRpZXNfEBZjb25zaWRlcmVkIGluZGVwZW5kZW50XmFwcGxpY2FibGUgbGF3XxAUZW5mb3JjaW5nIGNvbXBsaWFuY2VfECdwZXJtaXQgbGlua2luZyBwcm9wcmlldGFyeSBhcHBsaWNhdGlvbnNfEBdhdXRvbWF0aWNhbGx5IHRlcm1pbmF0ZV8QE2xpY2Vuc2VzIHRlcm1pbmF0ZWRfEBBsb3NzZXMgc3VzdGFpbmVkXnJpZ2h0cyBncmFudGVkXGxvc3Mgb2YgZGF0YV5yZWNlaXZlIGNvcGllc18QIWZyZWUgc29mdHdhcmUgZm91bmRhdGlvbiBzb2Z0d2FyZV8QD3JlY2VpdmVkIGNvcGllc1xtb3VzZS1jbGlja3NfEBhjZXJ0YWluIHJlc3BvbnNpYmlsaXRpZXNbd29ya3MgYmFzZWRfEBRtYWtpbmcgbW9kaWZpY2F0aW9uc113cml0dGVuIG9mZmVyXxAVaWRlbnRpZmlhYmxlIHNlY3Rpb25zXxAQbWFjaGluZS1yZWFkYWJsZV8QFGFsbGVnYXRpb24gb2YgcGF0ZW50XxAWY29weXJpZ2h0ZWQgaW50ZXJmYWNlc18QGmdudSBnZW5lcmFsIHB1YmxpYyBsaWNlbnNlXXByZWNpc2UgdGVybXNfEBFjZXJ0YWluIGNvdW50cmllc11mcmVlIHNvZnR3YXJlXxAQbGVnYWwgcGVybWlzc2lvbl8QD3B1Ymxpc2ggcmV2aXNlZFxjbGFpbSByaWdodHNfEBZyZXN0cmljdGlvbnMgdHJhbnNsYXRlXG5ldyB2ZXJzaW9uc18QFGNvcHlyaWdodCBkaXNjbGFpbWVyXxAPbGljZW5zZSBhcHBsaWVzXxAPc3RhcnRlZCBydW5uaW5nXxASaW1wbGllZCB3YXJyYW50aWVzXGVuZCBvZiB0ZXJtc1xlbnRpcmUgd2hvbGVbZnVsbCBub3RpY2VfEBRwcm9wcmlldGFyeSBwcm9ncmFtc18QE2NvbnRlbnRzIGNvbnN0aXR1dGVfEBhwdWJsaWMgbGljZW5zZSBwcmFjdGljZXNecGFydGllcyByZW1haW5fEBNyZWNlaXZlIHNvdXJjZSBjb2RlXxAicGVybWl0IHJveWFsdHktZnJlZSByZWRpc3RyaWJ1dGlvblxzY3JpcHRzIHVzZWRfECBvcHRpb24gb2ZmZXIgd2FycmFudHkgcHJvdGVjdGlvbl8QEWZvbGxvd2luZyBub3RpY2VzXG5ldyBwcm9ncmFtc18QF3JlY2lwaWVudCBhdXRvbWF0aWNhbGx5W25ldyBwcm9ncmFtXxATZGlzdHJpYnV0ZSBzb2Z0d2FyZV8QE29mZmVyaW5nIGVxdWl2YWxlbnRecHVibGljIGxpY2Vuc2VfEBhmcmVlIHNvZnR3YXJlIGZvdW5kYXRpb25fEBBjb250ZXN0IHZhbGlkaXR5XxAaZGlzdHJpYnV0aW9uIG9mIGRlcml2YXRpdmVfEBFyZXVzZSBvZiBzb2Z0d2FyZV8QE3NvZnR3YXJlIGZvdW5kYXRpb25fEBZjb25zaXN0ZW50IGFwcGxpY2F0aW9uXxAVaHlwb3RoZXRpY2FsIGNvbW1hbmRzXxAQaW1wbGllZCB3YXJyYW50eVlwYXJ0eSB3aG9eYXV0aG9ycyBjb21taXRbb2JqZWN0IGNvZGVfEBdnZW5lcmFsIHB1YmxpYyBsaWNlbnNlc18QD3Byb2dyYW0gc3ViamVjdF5uYW1lIG9mIGF1dGhvcl8QFnNwZWFrIG9mIGZyZWUgc29mdHdhcmVcaGVsZCBpbnZhbGlkXHRydWUgZGVwZW5kc18QE21lcmUgYWdncmVnYXRpb24gb2Zbc291cmNlIGZpbGVfEBRhZGRyZXNzIG5ldyBwcm9ibGVtc18QFmdlbmVyYWwgcHVibGljIGxpY2Vuc2VfEBBjb2xsZWN0aXZlIHdvcmtzXxAPcGh5c2ljYWwgYWN0IG9mXxARdmVyc2lvbiBwdWJsaXNoZWRcamFtZXMgaGFja2VyXXBhdGVudCBpc3N1ZXNfEBVhcHByb3ByaWF0ZWx5IHB1Ymxpc2hecHJlZmVycmVkIGZvcm1fEBdkaXN0cmlidXRpb24gY29uZGl0aW9uc18QEGV4dGVudCBwZXJtaXR0ZWRfEBpkaXN0cmlidXRpb24gb2YgZXhlY3V0YWJsZV8QImdudSBsaWJyYXJ5IGdlbmVyYWwgcHVibGljIGxpY2Vuc2VfEBB0ZXJtcyBvZiBzZWN0aW9uXxAVZXhjbHVzaW9uIG9mIHdhcnJhbnR5XxAVcGVydGluZW50IG9ibGlnYXRpb25zXxARdGVybXMgb2Ygc2VjdGlvbnNfEBFzcGVjaWFsIGV4Y2VwdGlvbl8QEW9yaWdpbmFsIGxpY2Vuc29yXxAUc29mdHdhcmUgaW50ZXJjaGFuZ2VcZXZlbnQgdW5sZXNzXxAUbGljZW5zZSBpbmNvcnBvcmF0ZXNfEBdjYXJyeSBwcm9taW5lbnQgbm90aWNlc18QF2xpY2Vuc2VkIGZyZWUgb2YgY2hhcmdlXxAUcGVybWl0IGluY29ycG9yYXRpbmdcZnJlZSBwcm9ncmFtXxARbmV3IGZyZWUgcHJvZ3JhbXNfEBNvcHRpb24gb2YgZm9sbG93aW5nXxARaW5jb3Jwb3JhdGUgcGFydHNfEBNwcm9ncmFtIHByb3ByaWV0YXJ5XxASZ251IGdlbmVyYWwgcHVibGljXxAccmVhZHMgY29tbWFuZHMgaW50ZXJhY3RpdmVseV8QGmludGVyZmFjZSBkZWZpbml0aW9uIGZpbGVzXxAxY29zdCBvZiBwaHlzaWNhbGx5IHBlcmZvcm1pbmcgc291cmNlIGRpc3RyaWJ1dGlvbl8QEGxpY2Vuc2UgZG9jdW1lbnRec2VwYXJhdGUgd29ya3NfEBNjb250cm9sIGNvbXBpbGF0aW9uXxAVY29uc2VxdWVudGlhbCBkYW1hZ2VzXm1vZGlmaWVkIGZpbGVzW2ZyZWUgc3RhdHVzXW5vdGljZSBwbGFjZWRfEBBjdXN0b21hcmlseSB1c2VkXxAXcHJvZ3JhbSBwcm92ZSBkZWZlY3RpdmVfEBJtZWRpdW0gY3VzdG9tYXJpbHlfEBFnbm9tb3Zpc2lvbiBjb21lc18QFXRocmVhdGVuZWQgY29uc3RhbnRseV8QE21vZGlmaWNhdGlvbiBmb2xsb3dbZW50aXJlIHJpc2tfEA9leGVjdXRhYmxlIHJ1bnNfEBJzdWJyb3V0aW5lIGxpYnJhcnlfEBNwcm9ibGVtcyBpbnRyb2R1Y2VkXxAQY29weXJpZ2h0IG5vdGljZV8QGm5vbmNvbW1lcmNpYWwgZGlzdHJpYnV0aW9uXxAPY29tcGxldGUgc291cmNlXxAQbW9kaWZpZWQgcHJvZ3JhbV8QD3ByZXNlbnQgdmVyc2lvbl8QE2dudSBsaWJyYXJ5IGdlbmVyYWxfEBNkaXN0cmlidXRpb24gbWVkaXVtXxAWYW5ub3VuY2VtZW50IGluY2x1ZGluZ18QFmRpc2NsYWltZXIgb2Ygd2FycmFudHlfEBZkaXN0aW5ndWlzaGluZyB2ZXJzaW9uXxAQbGljZW5zZWVzIGV4dGVuZFxtYWtlcyBwYXNzZXNcZGV0YWlscyB0eXBlXxAWc2F0aXNmeSBzaW11bHRhbmVvdXNseV8QD2V4ZWN1dGFibGUgZm9ybV8QE2dub21vdmlzaW9uIHZlcnNpb25aY29kZSBtZWFuc18QEmNvcHlyaWdodCBpbnRlcmVzdAAIALIAvQDQAOQA9gESAR8BMwFQAWMBdgGFAaoBwwHaAe8CAQIaAiwCQgJOAnIChwKaAqYCvgLuAvwDFQMkAzsDZQN/A5UDqAO3A8QD0wP3BAkEFgQxBD0EVARiBHoEjQSkBL0E2gToBPwFCgUdBS8FPAVVBWIFeQWLBZ0FsgW/BcwF2AXvBgUGIAYvBkUGagZ3BpoGrga7BtUG4Qb3Bw0HHAc3B0oHZwd7B5EHqgfCB9UH3wfuB/oIFAgmCDUITghbCGgIfgiKCKEIugjNCN8I8wkACQ4JJgk1CU8JYgl/CaQJtwnPCecJ+woPCiMKOgpHCl4KeAqSCqkKtgrKCuAK9AsKCx8LPgtbC48LoguxC8cL3wvuC/oMCAwbDDUMSgxeDHYMjAyYDKoMvwzVDOgNBQ0XDSoNPA1SDWgNgQ2aDbMNxg3TDeAN+Q4LDiEOLAAAAAAAAAIBAAAAAAAAAKgAAAAAAAAAAAAAAAAAAA5B 4078 SCHILY.xattr.com.apple.metadata:kMDItemKeyphraseLabels=bplist00  !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~Zpaper mail_copyright holder_copyright holders_sole purpose of_original copyright holder\short notice_distribute copies_distribute verbatim copies_operating system_derivative works^court judgment_"distribute copies of free software_wide range of software_everyone understands_requirements apply_patent licenses_generous contributions_full compliance_rendered inaccurate[third party_!free software distribution system_certain conditions_major components[source code_machine-readable copy_-explicit geographical distribution limitation]third parties_considered independent^applicable law_enforcing compliance_'permit linking proprietary applications_automatically terminate_licenses terminated_losses sustained^rights granted\loss of data^receive copies_!free software foundation software_received copies\mouse-clicks_certain responsibilities[works based_making modifications]written offer_identifiable sections_machine-readable_allegation of patent_copyrighted interfaces_gnu general public license]precise terms_certain countries]free software_legal permission_publish revised\claim rights_restrictions translate\new versions_copyright disclaimer_license applies_started running_implied warranties\end of terms\entire whole[full notice_proprietary programs_contents constitute_public license practices^parties remain_receive source code_"permit royalty-free redistribution\scripts used_ option offer warranty protection_following notices\new programs_recipient automatically[new program_distribute software_offering equivalent^public license_free software foundation_contest validity_distribution of derivative_reuse of software_software foundation_consistent application_hypothetical commands_implied warrantyYparty who^authors commit[object code_general public licenses_program subject^name of author_speak of free software\held invalid\true depends_mere aggregation of[source file_address new problems_general public license_collective works_physical act of_version published\james hacker]patent issues_appropriately publish^preferred form_distribution conditions_extent permitted_distribution of executable_"gnu library general public license_terms of section_exclusion of warranty_pertinent obligations_terms of sections_special exception_original licensor_software interchange\event unless_license incorporates_carry prominent notices_licensed free of charge_permit incorporating\free program_new free programs_option of following_incorporate parts_program proprietary_gnu general public_reads commands interactively_interface definition files_1cost of physically performing source distribution_license document^separate works_control compilation_consequential damages^modified files[free status]notice placed_customarily used_program prove defective_medium customarily_gnomovision comes_threatened constantly_modification follow[entire risk_executable runs_subroutine library_problems introduced_copyright notice_noncommercial distribution_complete source_modified program_present version_gnu library general_distribution medium_announcement including_disclaimer of warranty_distinguishing version_licensees extend\makes passes\details type_satisfy simultaneously_executable form_gnomovision versionZcode means_copyright interest3Pcv,BNr$;e 1=Tbz /<Uby /Ejw 7Jg{&5N[h~  & 5 O b   # : G ^ x  > [   5 J ^ v   * < R h  !,A 2802 LIBARCHIVE.xattr.com.apple.metadata:kMDItemKeyphraseConfidences=YnBsaXN0MDCvEKcBAgMEBQYHCAkKCwwNDg8QERITFBUWFxgZGhscHR4fICEiIyQlJicoKSorLC0uLzAxMjM0NTY3ODk6Ozw9Pj9AQUJDREVGR0hJSktMTU5PUFFSU1RVVldYWVpbXF1eX2BhYmNkZWZnaGlqa2xtbm9wcXJzdHV2d3h5ent8fX5/gIGCg4SFhoeIiYqLjI2Oj5CRkpOUlZaXmJmam5ydnp+goaKjpKWmpyM//Ov7CBAq9iM//EOz0AAAACM//BHTsAAAACM/9Z9aF33vhSM/9T445NAxkyM/9G7oyb94GCM/8eP04AAAACM/8bhbhNAxkCM/8aGZokm1TCM/8F24ijdBMiM/7w1TAAAAACM/7Oo2be0qsCM/60+sI2/XYCM/60tsAAAABCM/6vPkgAAAACM/6t6XgAAAACM/6pKHwAAAACM/6gMGwAAAACM/6exIwAAAACM/6Ty/Ea9wJCM/6LI6llRmHCM/6Gz3QAAAACM/6E+cgAAAACM/6EnxGcVuhCM/5+Od7ERuVSM/5wrfM8XyKCM/5uPSgAAAACM/5mg8wAAAACM/5gZwAAAAACM/5fp5wAAAACM/5fPU7nCUuCM/5T2EAAAAACM/5LypgAAAACM/49brQAAAACM/46DQAAAAACM/4p1syVxTFSM/4mfwAAAAACM/4mVFgvJ6PCM/4cJ8QAAAACM/4OwxgAAAACM/4NA0AAAAACM/4MNJ+z0RDCM/4L9fEalaHCM/4ES7AAAAACM/4D9tAAAAACM/3rdPAAAAACM/3nSKiUy6ICM/3iHhAAAAACM/3U34Py/FkCM/3SO4AAAAACM/3QUrgAAAACM/3NYo+YKDECM/2qRTgAAAACM/2npPAAAAACM/2XAbgAAAACM/2WUEAAAAACM/2NJuAAAAACM/1kBmAAAAACM/1csLAAAAACM/1ameobvyyCM/1VgaAAAAACM/1GI+r1p2yyM/1DxgPsMxoCM/09SOZv3gYCM/0wrSgAAAACM/0uEsAAAAACM/0rZFZUCTqyM/0guSgAAAACM/0YT9yx7ldSM/0RF7YxDloCM/0PdOIIdN2CM/0J4WHOEpcCM/z26eAAAAACM/z0dwAAAAACM/zZ4CAAAAACM/zVhYcFgoACM/zUb08wUGICM/zEYkAAAAACM/zA9Z9f9oICM/y5kKyITmACM/yKqMAAAAACM/yHbSvUQe1SM/x83OOq0DayM/x29+AAAAACM/xt2GJCdRkCM/xktgAAAAACM/xSByAAAAACM/wYAAAAAAACM/wFPQAAAAACM/wEbSZxW6ACM/v+DFolhuVSM/vyJYAAAAACM/vSkMfF5OVSM/usn4hzE2YCM/uOyIAAAAACM/t+O8AAAAACM/tD/lTfFY1SM/s+EYisOGwCM/ss7GeLGd1SM/sn7m0AWwVSM/q+y5RugmgCM/qd6B1zCwVSM/ptlIAAAAACM/oUKgAAAAACM/m6YoiqYhACM/mBQgAAAAACM/ltewAAAAACM/lIhwAAAAACM/jDYgAAAAACM/i6QXv3BFVSM/iKpO+fPTMyM/b2ro/S+AACM/bcjvUQe6qyO/eFIAAAAAACO/lIUeFd8IqyO/lSRAAAAAACO/lWfZElV2ACO/mPCAAAAAACO/m/kzBFecACO/pN44AAAAACO/qxdqEKR4qyO/sKbikHfBQCO/swywAAAAACO/s+4lH0+wACO/tZXbrDgEgCO/tmFgqwUIqyO/uBLtgezbQCO/uMREAAAAACO/uzb8sojdqyO/vMleMIASqyO/vNiVVhSgACO/wGg9/2yZ6yO/wIoWV6zCwCO/wbLxrkX2YCO/wwdaAAAAACO/xun2AAAAACO/yFJXpqnvICO/ySP22NTMwCO/yWAsAAAAACO/yhhFvvFkQCO/yips1qOlQCO/ytl6mfoSwCO/y4YXel30ACO/y5pEAAAAACO/zFmiAAAAACO/zIeutgXr0CO/zdLdRaEBoCO/ziOUaoGHACO/zrhoAAAAACO/zxPAMgQ/QCO/0Kiw8LHM+CO/0ReFhVMX8CO/0YqLR9PsACO/0gVoXcXa0CO/1mB/ucj+1SO/2T02AAAAACO/2cFF54XhMCO/2il1IV3wiyO/3CNrXcXa0CO/3ExUAAAAACO/3VPEsWyucCO/3ZObwRc/ACO/3u1VHUzuICO/30AaAAAAACO/4H3ULuLtaCO/4dhvJ7iEmCO/5phmIAbAEAAIALIAuwDEAM0A1gDfAOgA8QD6AQMBDAEVAR4BJwEwATkBQgFLAVQBXQFmAW8BeAGBAYoBkwGcAaUBrgG3AcAByQHSAdsB5AHtAfYB/wIIAhECGgIjAiwCNQI+AkcCUAJZAmICawJ0An0ChgKPApgCoQKqArMCvALFAs4C1wLgAukC8gL7AwQDDQMWAx8DKAMxAzoDQwNMA1UDXgNnA3ADeQOCA4sDlAOdA6YDrwO4A8EDygPTA9wD5QPuA/cEAAQJBBIEGwQkBC0ENgQ/BEgEUQRaBGMEbAR1BH4EhwSQBJkEogSrBLQEvQTGBM8E2AThBOoE8wT8BQUFDgUXBSAFKQUyBTsFRAVNBVYFXwVoBXEFegWDBYwFlQWeBacFsAW5BcIFywXUBd0F5gXvBfgGAQYKBhMGHAYlBi4GNwZABkkGUgZbBmQGbQZ2Bn8GiAAAAAAAAAIBAAAAAAAAAKgAAAAAAAAAAAAAAAAAAAaR 2115 SCHILY.xattr.com.apple.metadata:kMDItemKeyphraseConfidences=bplist00  !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~#?*#?C#?Ӱ#?Z}#?>81#?nɿx#?#?[1#?񡙢IL#?]7A2#? S#?6m*#?O#o`#?Kl#?#?ޗ#?ꒇ#?#?H#?<p$#?:Tf#?l@#?O#?In#?DnU#? 3(#?Ҁ#?h<#?p#?y#?p#?=#?伩#?@#?#?l\S#?g#?eEz<#?|@#?1#?4#?I= #?_Z#?D#??m#?޷O#?tL #?!#?M?/Ő#?##?+#?(#?ڤS#?zO#?p#?e#?n#?@f#? #?թ#?X#?b>Zv#?<`>1#?Ԏf`#? Ҁ#?,#?ҶEe@#? #?фu#?{c#?N M#?О)p#?n#?Gp#?͞#?XXpX(#?F #?F$#?Yh #?˙ Ȅ#?Ȫ#?vҽD#?:k#?o~#?݆$'Q#?K`#? r#?#?S#?Fg#?ŢXnU#?"X#?) |^NU#?16`#?#?#??MX#?Æ#?x#?~U#?F&#?ށ0U#?H#?B#?(!#? #?װ#?p#?6 #?pEU#?N3#?oj/#?mQ#xR##$@#gUv##3W#8#jx#w@# #%O#۬8#a`#@#D#6ݫ#^0#ؕV#h=l#W#E`#Z##RW ###`,#Ed@#*l֣@#z#ˆz]#˚D#Y#̇#E##j#θh#2?@#Ш#S#ъG#h]#`#=6#E0#)u!]##k]#LT#Sılp#ݓ?#UL #@#}.h#o'#f  '09BKT]fox#,5>GPYbkt} (1:CLU^gpy $-6?HQZclu~ )2;DMV_hqz %.7@IR[dmv IPC-Shareable-1.19/COPYING000644 000765 000024 00000043076 14210441431 015273 0ustar00stevestaff000000 000000 GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19yy name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. IPC-Shareable-1.19/MANIFEST.SKIP000644 000765 000024 00000000752 15205663032 016140 0ustar00stevestaff000000 000000 ^images/ .bs$ .c$ .sh$ \.o$ ~$ ^blib/ ^pm_to_blib/ \.old$ \.orig$ \.tar$ \.tar.gz$ \.bak$ \.swp$ \.hg/ \.hgignore$ ^_build/ ^Build$ ^MYMETA\.yml$ ^MYMETA\.json$ ^README.bak$ ^Makefile$ \.metadata/ \.idea/ pm_to_blib$ \.git/ \.debug$ \.gitignore$ \.ignore.txt$ \.travis.yml$ \.iml$ build/ ^\w+.list$ \.bblog$ \.base$ main$ .github/ ^testing/ ^benchmarks/ ^.vscode/ ^_Inline/ agent.txt ^cover_db/ ^ci/ ^CLAUDE.md$ .DS_Store$ ^nytprof.out$ profiling/ ^plans/ TESTING.md ^[^/]+\.md$ ^\.claude/ IPC-Shareable-1.19/META.yml000644 000765 000024 00000001573 15222770207 015517 0ustar00stevestaff000000 000000 --- abstract: 'Use shared memory backed variables across processes' author: - 'Steve Bertrand ' build_requires: IPC::Semaphore: '0' Mock::Sub: '1.09' Test::More: '0.98' Test::SharedFork: '0.35' configure_requires: ExtUtils::MakeMaker: '6.72' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: IPC-Shareable no_index: directory: - t - inc requires: Class::Struct: '0' Digest::MD5: '0' JSON: '0' Scalar::Util: '0' Storable: '0.607' String::CRC32: '0' perl: '5.010' resources: bugtracker: https://github.com/stevieb9/ipc-shareable/issues repository: https://github.com/stevieb9/ipc-shareable.git version: '1.19' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' IPC-Shareable-1.19/lib/000755 000765 000024 00000000000 15222770207 015006 5ustar00stevestaff000000 000000 IPC-Shareable-1.19/Makefile.PL000644 000765 000024 00000004647 15207155006 016222 0ustar00stevestaff000000 000000 use strict; use warnings; use Config; use ExtUtils::MakeMaker; my $ccflags = $Config{ccflags}; my $lddlflags = $Config{lddlflags}; # On macOS, system cc may target a different architecture than Perl was # built for (e.g. x86_64 perlbrew under Rosetta on Apple Silicon). # uname -m lies under Rosetta; use sysctl instead. if ($^O eq 'darwin') { my $arm64_native = `sysctl -n hw.optional.arm64 2>/dev/null`; chomp $arm64_native; if ($arm64_native && $ccflags !~ /arm64/ && $ccflags !~ /-arch/) { $ccflags .= ' -arch x86_64'; $lddlflags .= ' -arch x86_64'; } } my $have_cc = system(qq(echo 'int main(void){return 0;}' | $Config{cc} $ccflags -xc - -o /dev/null 2>/dev/null)) == 0; my @xs_args; if ($have_cc) { @xs_args = (XS => { 'Shareable.xs' => 'Shareable.c' }); } else { @xs_args = (XS => {}, C => [], PL_FILES => {}); } WriteMakefile( NAME => 'IPC::Shareable', VERSION_FROM => 'lib/IPC/Shareable.pm', CCFLAGS => $ccflags, LDDLFLAGS => $lddlflags, ($] >= 5.010 ? (ABSTRACT_FROM => 'lib/IPC/Shareable.pm', AUTHOR => 'Steve Bertrand ') : ()), LIBS => [], DEFINE => '', INC => '', @xs_args, META_MERGE => { 'meta-spec' => { version => 2 }, resources => { bugtracker => { web => 'https://github.com/stevieb9/ipc-shareable/issues', }, repository => { type => 'git', url => 'https://github.com/stevieb9/ipc-shareable.git', web => 'https://github.com/stevieb9/ipc-shareable', }, }, }, MIN_PERL_VERSION => 5.010, LICENSE => 'perl_5', CONFIGURE_REQUIRES => { 'ExtUtils::MakeMaker' => 6.72, }, BUILD_REQUIRES => { 'IPC::Semaphore' => 0, 'Mock::Sub' => 1.09, 'Test::More' => 0.98, 'Test::SharedFork' => 0.35, }, PREREQ_PM => { 'Class::Struct' => 0, 'Digest::MD5' => 0, 'JSON' => 0, 'Scalar::Util' => 0, 'Storable' => 0.607, 'String::CRC32' => 0, }, ); # Strip macOS extended attributes and AppleDouble metadata from dist # tarballs (LIBARCHIVE.xattr.* headers cause warnings on Linux tar). sub MY::postamble { return $^O eq 'darwin' ? "TARFLAGS = --no-mac-metadata -cvf\n" : ''; } IPC-Shareable-1.19/CREDITS000644 000765 000024 00000001573 14210441431 015254 0ustar00stevestaff000000 000000 CREDITS This project was initiated by myself (Ben Sugars) in August, 1997. After a prolonged absence, I returned to the project in the winter of 2000. Maurice Aubrey co-authored some earlier versions with me. Thanks! Thanks to all others with comments or bug fixes, especially: Stephane Bortzmeyer Doug MacEachern Robert Emmery Mohammed J. Kabir Terry Ewing Tim Fries Joe Thomas Paul Makepeace Raphael Manfredi Lee.Lindley@bigfoot.com Dave Rolsky If you notice any problems, create any patches, or add any features, be sure to let me know so your name can be in the above list! -- Ben Sugars March 5, 2001 IPC-Shareable-1.19/META.json000644 000765 000024 00000003035 15222770210 015654 0ustar00stevestaff000000 000000 { "abstract" : "Use shared memory backed variables across processes", "author" : [ "Steve Bertrand " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "IPC-Shareable", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "IPC::Semaphore" : "0", "Mock::Sub" : "1.09", "Test::More" : "0.98", "Test::SharedFork" : "0.35" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.72" } }, "runtime" : { "requires" : { "Class::Struct" : "0", "Digest::MD5" : "0", "JSON" : "0", "Scalar::Util" : "0", "Storable" : "0.607", "String::CRC32" : "0", "perl" : "5.010" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/stevieb9/ipc-shareable/issues" }, "repository" : { "type" : "git", "url" : "https://github.com/stevieb9/ipc-shareable.git", "web" : "https://github.com/stevieb9/ipc-shareable" } }, "version" : "1.19", "x_serialization_backend" : "JSON::PP version 4.07" } IPC-Shareable-1.19/lib/IPC/000755 000765 000024 00000000000 15222770207 015421 5ustar00stevestaff000000 000000 IPC-Shareable-1.19/lib/IPC/Shareable.pm000644 000765 000024 00000374515 15222764710 017666 0ustar00stevestaff000000 000000 package IPC::Shareable; use warnings; use strict; require 5.010; use Carp qw(croak confess carp); use Config; use Errno qw(EINVAL ENOMEM ENOSPC); use Digest::MD5 qw(md5_hex); use IPC::Semaphore; use IPC::Shareable::SharedMem; use IPC::SysV qw( IPC_PRIVATE IPC_CREAT IPC_EXCL IPC_NOWAIT IPC_RMID IPC_STAT SEM_UNDO ); use JSON qw(-convert_blessed_universally); use Scalar::Util; use String::CRC32; use Storable 0.6 qw(freeze thaw); our $VERSION = '1.19'; # eval() returns 1 on success; // 0 coerces undef (failure) to 0 so callers # can boolean-test cleanly without checking definedness. our $_have_xs = ! $ENV{IPC_SHAREABLE_NO_XS} && eval { require XSLoader; XSLoader::load('IPC::Shareable', $VERSION); 1; } // 0; use constant { # Locking LOCK_SH => 1, LOCK_EX => 2, LOCK_NB => 4, LOCK_UN => 8, # SHM parameters SHM_BUFSIZ => 65536, SHMMAX_BYTES => 1073741824, # ~1 GB SHM_EXISTS => 1, # Semaphore slots (4 slots always; 5th slot added when 'testing' is set) SEM_MARKER => 0, SEM_READERS => 1, SEM_WRITERS => 2, SEM_PROTECTED => 3, SEM_TESTING => 4, # Perl sends in a double as opposed to an integer to shmat(), and on some # systems, this causes the IPC system to round down to the maximum integer # size of 0x80000000. We correct that when generating keys with CRC32. MAX_KEY_INT_SIZE => 0x80000000, # Number of times we'll check for existing segs EXCLUSIVE_CHECK_LIMIT => 10, # Struct types TYPE_HASH => 0, TYPE_ARRAY => 1, TYPE_SCALAR => 2, }; require Exporter; our @ISA = 'Exporter'; our @EXPORT_OK = qw( LOCK_EX LOCK_SH LOCK_NB LOCK_UN SEM_MARKER SEM_READERS SEM_WRITERS SEM_PROTECTED SEM_TESTING ); our %EXPORT_TAGS = ( all => [ qw( LOCK_EX LOCK_SH LOCK_NB LOCK_UN ), qw( SEM_MARKER SEM_READERS SEM_WRITERS SEM_PROTECTED SEM_TESTING ), ], lock => [qw( LOCK_EX LOCK_SH LOCK_NB LOCK_UN )], flock => [qw( LOCK_EX LOCK_SH LOCK_NB LOCK_UN )], semaphores => [qw( SEM_MARKER SEM_READERS SEM_WRITERS SEM_PROTECTED SEM_TESTING )], ); # Locking scheme copied from IPC::ShareLite (with minor modifications) my %semop_args = ( (LOCK_EX), [ SEM_READERS, 0, 0, # Wait for readers to finish SEM_WRITERS, 0, 0, # Wait for writers to finish SEM_WRITERS, 1, SEM_UNDO, # Assert write lock ], (LOCK_EX|LOCK_NB), [ SEM_READERS, 0, IPC_NOWAIT, # Wait for readers to finish SEM_WRITERS, 0, IPC_NOWAIT, # Wait for writers to finish SEM_WRITERS, 1, (SEM_UNDO | IPC_NOWAIT), # Assert write lock ], (LOCK_EX|LOCK_UN), [ SEM_WRITERS, -1, (SEM_UNDO | IPC_NOWAIT), ], (LOCK_SH), [ SEM_WRITERS, 0, 0, # Wait for writers to finish SEM_READERS, 1, SEM_UNDO, # Assert shared read lock ], (LOCK_SH|LOCK_NB), [ SEM_WRITERS, 0, IPC_NOWAIT, # Wait for writers to finish SEM_READERS, 1, (SEM_UNDO | IPC_NOWAIT), # Assert shared read lock ], (LOCK_SH|LOCK_UN), [ SEM_READERS, -1, (SEM_UNDO | IPC_NOWAIT), # Remove shared read lock ], ); my %default_options = ( key => IPC_PRIVATE, create => 0, exclusive => 0, destroy => 0, mode => 0666, size => SHM_BUFSIZ, protected => 0, testing => 0, limit => 1, graceful => 0, warn => 0, serializer => 'json', enforced_write_locking => 1, enforced_read_locking => 1, violated_write_lock_warn => 1, violated_read_lock_warn => 1, ); # Class-level variables my %global_register; my %process_register; my %used_ids; my $_testing_dist = ''; # Set once we have warned that a semaphore set vanished mid-unlock (a peer # removed it). Keeps the warning to one line per process rather than per call. my $_unlock_einval_warned = 0; # "Magic" methods sub TIESCALAR { return _tie('SCALAR', @_); } sub TIEARRAY { return _tie('ARRAY', @_); } sub TIEHASH { return _tie('HASH', @_); } sub STORE { my $knot = shift; return if ! _write_permitted($knot); $knot->{_data} = $knot->_decode($knot->seg) unless ($knot->{_lock}); if ($knot->{_type_int} == TYPE_HASH) { my ($key, $val) = @_; _remove_child($knot->{_data}{$key}); _magic_tie($knot, $val) if ref($val) && $knot->_need_tie($val); $knot->{_data}{$key} = $val; } elsif ($knot->{_type_int} == TYPE_ARRAY) { my ($i, $val) = @_; _remove_child($knot->{_data}[$i]); _magic_tie($knot, $val) if ref($val) && $knot->_need_tie($val); $knot->{_data}[$i] = $val; } elsif ($knot->{_type_int} == TYPE_SCALAR) { my ($val) = @_; if ($knot->{_data} && ref($knot->{_data})) { _remove_child(${$knot->{_data}}); } _magic_tie($knot, $val) if ref($val) && $knot->_need_tie($val); $knot->{_data} = \$val; } if ($knot->{_lock} & LOCK_EX) { $knot->{_was_changed} = 1; } else { _write_to_seg($knot); } return 1; } sub FETCH { my $knot = shift; my $data; if ($knot->{_lock}) { $data = $knot->{_data}; } else { _read_check($knot); $data = $knot->_decode($knot->seg); $knot->{_data} = $data; } my $val; if ($knot->{_type_int} == TYPE_HASH) { my $key = shift; $val = $data->{$key}; } elsif ($knot->{_type_int} == TYPE_ARRAY) { my $i = shift; $val = $data->[$i]; } elsif ($knot->{_type_int} == TYPE_SCALAR) { if (defined $data) { $val = $$data; } else { return; } } if (ref($val) && (my $inner = _is_child($val))) { # Register the inner knot so clean_up_all() can find it even when it # was created in a forked child process if (! exists $global_register{$inner->seg->id}) { $global_register{$inner->seg->id} = $inner; } unless ($inner->{_lock}) { my $s = $inner->seg; $inner->{_data} = $knot->_decode($s); } } return $val; } sub CLEAR { my $knot = shift; return if ! _write_permitted($knot); $knot->{_data} = $knot->_decode($knot->seg) unless $knot->{_lock}; if ($knot->{_type_int} == TYPE_HASH) { for my $val (values %{ $knot->{_data} }) { _remove_child($val); } $knot->{_data} = { }; } elsif ($knot->{_type_int} == TYPE_ARRAY) { for my $val (@{ $knot->{_data} }) { _remove_child($val); } $knot->{_data} = [ ]; } if ($knot->{_lock} & LOCK_EX) { $knot->{_was_changed} = 1; } else { _write_to_seg($knot); } } sub DELETE { my $knot = shift; my $key = shift; croak "Cannot delete from a non-hash tied variable" unless $knot->{_type_int} == TYPE_HASH; return if ! _write_permitted($knot); $knot->{_data} = $knot->_decode($knot->seg) unless $knot->{_lock}; my $val = delete $knot->{_data}->{$key}; _remove_child($val); if ($knot->{_lock} & LOCK_EX) { $knot->{_was_changed} = 1; } else { _write_to_seg($knot); } return $val; } sub EXISTS { my $knot = shift; my $key = shift; $knot->{_data} = $knot->_decode($knot->seg) unless $knot->{_lock}; return exists $knot->{_data}->{$key}; } sub FIRSTKEY { my $knot = shift; $knot->{_data} = $knot->_decode($knot->seg) unless $knot->{_lock}; $knot->{_hkey_list} = [ keys %{$knot->{_data}} ]; return $knot->NEXTKEY; } sub NEXTKEY { my ($knot, $last_key_accessed) = @_; # We don't use ordered hashes, so we don't need to use # the last key accessed parameter # Caveat emptor if hash was changed by another process return shift @{$knot->{_hkey_list}}; } sub EXTEND { #XXX Noop } sub PUSH { my $knot = shift; croak "Cannot push to a non-array tied variable" unless $knot->{_type_int} == TYPE_ARRAY; return if ! _write_permitted($knot); $knot->{_data} = $knot->_decode($knot->seg, $knot->{_data}) unless $knot->{_lock}; push @{$knot->{_data}}, @_; if ($knot->{_lock} & LOCK_EX) { $knot->{_was_changed} = 1; } else { _write_to_seg($knot); } } sub POP { my $knot = shift; croak "Cannot pop from a non-array tied variable" unless $knot->{_type_int} == TYPE_ARRAY; return if ! _write_permitted($knot); $knot->{_data} = $knot->_decode($knot->seg, $knot->{_data}) unless $knot->{_lock}; my $val = pop @{$knot->{_data}}; if ($knot->{_lock} & LOCK_EX) { $knot->{_was_changed} = 1; } else { _write_to_seg($knot); } return $val; } sub SHIFT { my $knot = shift; croak "Cannot shift from a non-array tied variable" unless $knot->{_type_int} == TYPE_ARRAY; return if ! _write_permitted($knot); $knot->{_data} = $knot->_decode($knot->seg, $knot->{_data}) unless $knot->{_lock}; my $val = shift @{$knot->{_data}}; if ($knot->{_lock} & LOCK_EX) { $knot->{_was_changed} = 1; } else { _write_to_seg($knot); } return $val; } sub UNSHIFT { my $knot = shift; croak "Cannot unshift a non-array tied variable" unless $knot->{_type_int} == TYPE_ARRAY; return if ! _write_permitted($knot); $knot->{_data} = $knot->_decode($knot->seg, $knot->{_data}) unless $knot->{_lock}; my $val = unshift @{$knot->{_data}}, @_; if ($knot->{_lock} & LOCK_EX) { $knot->{_was_changed} = 1; } else { _write_to_seg($knot); } return $val; } sub SPLICE { my($knot, $off, $n, @av) = @_; croak "Cannot splice a non-array tied variable" unless $knot->{_type_int} == TYPE_ARRAY; return if ! _write_permitted($knot); $knot->{_data} = $knot->_decode($knot->seg, $knot->{_data}) unless $knot->{_lock}; my @val = splice @{$knot->{_data}}, $off, $n, @av; if ($knot->{_lock} & LOCK_EX) { $knot->{_was_changed} = 1; } else { _write_to_seg($knot); } return @val; } sub FETCHSIZE { my $knot = shift; croak "Cannot fetchsize on a non-array tied variable" unless $knot->{_type_int} == TYPE_ARRAY; $knot->{_data} = $knot->_decode($knot->seg) unless $knot->{_lock}; return scalar(@{$knot->{_data}}); } sub STORESIZE { my $knot = shift; my $n = shift; croak "Cannot storesize on a non-array tied variable" unless $knot->{_type_int} == TYPE_ARRAY; return if ! _write_permitted($knot); $knot->{_data} = $knot->_decode($knot->seg) unless $knot->{_lock}; $#{$knot->{_data}} = $n - 1; if ($knot->{_lock} & LOCK_EX) { $knot->{_was_changed} = 1; } else { _write_to_seg($knot); } return $n; } # Public methods *shlock = \&lock; *shunlock = \&unlock; # End user methods sub new { my ($class, %opts) = @_; my $type = $opts{var} || 'HASH'; if ($type eq 'HASH') { tie my %h, 'IPC::Shareable', \%opts; return \%h; } if ($type eq 'ARRAY') { tie my @a, 'IPC::Shareable', \%opts; return \@a; } if ($type eq 'SCALAR') { tie my $s, 'IPC::Shareable', \%opts; return \$s; } } sub lock { my $knot = shift; my ($flags, $code); if (scalar @_ == 2) { ($flags, $code) = @_; } if (defined $_[0]) { if (ref $_[0] eq 'CODE') { $code = shift; } else { $flags = shift; } } if (defined $code && ref $code ne 'CODE') { croak "\$code param to lock() must be a code reference"; } $flags = LOCK_EX if ! defined $flags; # unlock() was called return $knot->unlock if ($flags & LOCK_UN); # Caller already has the same lock type if ($knot->{_lock} & $flags) { if ($code && $flags == LOCK_EX) { _execute_lock_coderef($knot, $code); } return 1; } # If they have a different lock than they want, release it first $knot->unlock if ($knot->{_lock}); my $sem = $knot->sem; my $lock_success = $sem->op(@{ $semop_args{$flags} }); if ($lock_success) { $knot->{_lock} = $flags; $knot->{_data} = $knot->_decode($knot->seg); my $locked_ref = _lock_children($knot, $flags); if (! $locked_ref) { my $rflags = $knot->{_lock} | LOCK_UN; $rflags ^= LOCK_NB if $rflags & LOCK_NB; $knot->sem->op(@{ $semop_args{$rflags} }); $knot->{_lock} = 0; $lock_success = 0; } else { $knot->{_locked_children} = $locked_ref; } } if ($flags == LOCK_EX && $lock_success && $code) { _execute_lock_coderef($knot, $code); return 1; } return $lock_success; } sub unlock { my $knot = shift; return 1 unless $knot->{_lock}; if ($knot->{_was_changed}) { _write_to_seg($knot); $knot->{_was_changed} = 0; } # Unlock children/nested segs in reverse order for my $child (reverse @{ $knot->{_locked_children} // [] }) { if ($child->{_was_changed}) { _write_to_seg($child); $child->{_was_changed} = 0; } my $child_flags = $child->{_lock} | LOCK_UN; $child_flags ^= LOCK_NB if $child_flags & LOCK_NB; $child->sem->op(@{ $semop_args{$child_flags} }); $child->{_lock} = 0; } $knot->{_locked_children} = []; # Release semaphore locks my $sem = $knot->sem; my $flags = $knot->{_lock} | LOCK_UN; $flags ^= LOCK_NB if ($flags & LOCK_NB); if (! $sem->op(@{ $semop_args{$flags} })) { if ($!{EINVAL}) { # The semaphore set was removed by another process (eg. a peer # holding the same segment with destroy=>1 exited). The lock we # held went away with it, so there is nothing left to release. # Warn once and carry on rather than aborting the caller; every # other errno is a real failure and stays fatal. This mirrors the # read path's tolerance of an unreachable set (see _write_permitted # and _check_read_lock). carp "Semaphore set gone during unlock (removed by another " . "process); treating the lock as already released" if ! $_unlock_einval_warned; $_unlock_einval_warned = 1; } else { croak "Could not release semaphore lock: $!\n"; } } $knot->{_lock} = 0; 1; } sub singleton { # If called with IPC::Shareable::singleton() as opposed to # IPC::Shareable->singleton(), the class isn't sent in. Check # for this and fix it if necessary if (! defined $_[0] || $_[0] ne __PACKAGE__) { unshift @_, __PACKAGE__; } my ($class, $glue, $warn) = @_; if (! defined $glue) { croak "singleton() requires a GLUE parameter"; } $warn = 0 if ! defined $warn; tie my $lock, 'IPC::Shareable', { key => $glue, create => 1, exclusive => 1, graceful => 1, destroy => 1, warn => $warn }; return $$; } # Helper, maintenance and developer methods sub attributes { my ($knot, $attr) = @_; if (defined $attr) { return $knot->{attributes}{$attr}; } else { return $knot->{attributes}; } } sub global_register { return \%global_register; } sub process_register { return \%process_register; } sub uuid { my ($knot) = @_; if (! defined $knot->{_uuid}) { $knot->{_uuid} = md5_hex(rand()); } return $knot->{_uuid}; } sub seg { my ($knot) = @_; return $knot->{_shm} if defined $knot->{_shm}; } sub sem { my ($knot) = @_; return $knot->{_sem} if defined $knot->{_sem}; } sub shm_segments { shift if ref($_[0]) || (defined $_[0] && ! ref($_[0]) && UNIVERSAL::isa($_[0], __PACKAGE__)); my ($filter_key) = @_; my $filter_int = _key_str_to_int($filter_key) if defined $filter_key; my %segments; open my $ipcs_fh, '-|', 'ipcs', '-m' or die "ipcs -m: $!"; while (my $line = <$ipcs_fh>) { my ($id, $raw_key); if ($line =~ /^\s*m\s+(\d+)\s+(\S+)/) { # BSD/macOS format: m ... ($id, $raw_key) = ($1, $2); } elsif ($line =~ /^\s*(\d+)\s+(0x[0-9a-fA-F]+)\s+/) { # DragonFly BSD format: ... (no 'm' type column) ($id, $raw_key) = ($1, $2); } elsif ($line =~ /^\s*(\S+)\s+(\d+)\s+\S+/) { # Linux format: ... ($raw_key, $id) = ($1, $2); } else { next; } my $key_int = $raw_key =~ /^0x[0-9a-fA-F]+$/ ? hex($raw_key) : $raw_key =~ /^\d+$/ ? int($raw_key) : next; my $hex_key = sprintf('0x%08x', $key_int); next if $key_int == 0; # IPC_PRIVATE segments can't be found by key # Get segment size via IPC_STAT my $stat_buf = ''; shmctl($id, IPC_STAT, $stat_buf) or next; my ($segsz) = $^O eq 'linux' ? ( $Config{longsize} == 8 ? unpack('x[48] Q', $stat_buf) # 64-bit Linux : unpack('x[36] L', $stat_buf) ) # 32-bit Linux : $^O eq 'freebsd' && $Config{longsize} == 8 ? unpack('x[32] Q', $stat_buf) # 64-bit FreeBSD (key_t=long=8, ipc_perm=32) : $^O eq 'solaris' ? ( $Config{longsize} == 8 ? unpack('x[32] Q', $stat_buf) # 64-bit Solaris (ipc_perm=28 + pad 4) : unpack('x[44] L', $stat_buf) ) # 32-bit Solaris (ipc_perm=44) : $^O eq 'openbsd' && $Config{longsize} == 8 ? unpack('x[32] L', $stat_buf) # 64-bit OpenBSD: segsz is int (4 bytes) : $^O eq 'dragonfly' && $Config{longsize} == 8 ? unpack('x[32] Q', $stat_buf) # 64-bit DragonFly (ipc_perm=28 + pad 4; segsz=size_t=8) : unpack('x[24] Q', $stat_buf); # macOS next unless $segsz; # Probe the 14-byte tag first so we don't pull entire foreign # segments (which may be gigabytes) into Perl just to discard them. my $head = ''; shmread($id, $head, 0, 14) or next; next unless $head eq 'IPC::Shareable'; my $data = ''; shmread($id, $data, 0, $segsz) or next; # Strip trailing null bytes $data =~ s/\x00+$//; my $json_part = substr($data, 14); my @child_keys = ($json_part =~ /"child_key_hex":"([^"]+)"/g); $segments{$hex_key} = { child_keys => \@child_keys, content => $data, id => $id, local_process => (exists $process_register{$id} ? 1 : 0), known => (exists $global_register{$id} ? 1 : 0), }; } close $ipcs_fh; if (defined $filter_int) { # Walk the segment tree starting from the root whose key matches # $filter_int, collecting it and all its descendants. Use integer # comparison so that hex formatting differences (zero-padding, case) # between ipcs(1) output and child_key_hex values don't matter. my %int_to_hex = map { hex($_) => $_ } keys %segments; my (%related, @queue); push @queue, $filter_int; while (my $k_int = shift @queue) { my $k_hex = $int_to_hex{$k_int} // next; next if $related{$k_hex}++; push @queue, map { hex($_) } @{ $segments{$k_hex}{child_keys} }; } %segments = map { $_ => $segments{$_} } keys %related; } return \%segments; } sub unknown_segments { shift if ref $_[0]; # Allow for object or class method call my $segs = shm_segments(); return grep { ! $segs->{$_}{known} } keys %$segs; } sub seg_count { my $count = 0; open my $ipcs_fh, '-|', 'ipcs', '-m' or die "ipcs -m: $!"; while (my $line = <$ipcs_fh>) { if ($line =~ /^\s*m\s+\d+\s+\S+/) { # BSD/macOS format: m ... $count++; } elsif ($line =~ /^\s*\d+\s+0x[0-9a-fA-F]+\s+/) { # DragonFly BSD: ... (no type-letter column) $count++; } elsif ($line =~ /^\s*(?:0x[0-9a-fA-F]+|\d+)\s+\d+\s+\S+/) { # Linux format: ... $count++; } } close $ipcs_fh; return $count; } sub sem_count { my $count = 0; open my $ipcs_fh, '-|', 'ipcs', '-s' or die "ipcs -s: $!"; while (my $line = <$ipcs_fh>) { if ($line =~ /^\s*s\s+\d+\s+\S+/) { # BSD/macOS format: s ... $count++; } elsif ($line =~ /^\s*\d+\s+0x[0-9a-fA-F]+\s+/) { # DragonFly BSD: ... (no type-letter column) $count++; } elsif ($line =~ /^\s*(?:0x[0-9a-fA-F]+|\d+)\s+\d+\s+\S+/) { # Linux format: ... $count++; } } close $ipcs_fh; return $count; } sub seg_map { croak "seg_map() must be called as an object method" unless ref $_[0]; my $knot_filter = shift; my $segs = shm_segments(); # Build hex_key -> OS segment ID from shm_segments() data my %id_by_hex; $id_by_hex{ $_ } = $segs->{$_}{id} for keys %$segs; # Build hex_key -> knot from global_register (keyed by seg_id) my %knot_by_hex; for my $id (keys %global_register) { my $knot = $global_register{$id}; my $hex = $knot->{_key_hex}; $knot_by_hex{$hex} = $knot if defined $hex; } # Supplement child_keys from global_register for Storable segments. # shm_segments() only extracts child_key_hex from JSON segment content; # for Storable we walk each knot's _data looking for tied child references my %extra_child_keys; # hex_key -> [ child_hex, ... ] for my $hex (keys %knot_by_hex) { my $knot = $knot_by_hex{$hex}; my $data = $knot->{_data}; my $rtype = Scalar::Util::reftype($data) // ''; my @vals = $rtype eq 'HASH' ? values %$data : $rtype eq 'ARRAY' ? @$data : (); for my $v (@vals) { next unless ref($v); my $vtype = Scalar::Util::reftype($v) // ''; my $child_knot; if ($vtype eq 'HASH') { $child_knot = tied(%$v) } elsif ($vtype eq 'ARRAY') { $child_knot = tied(@$v) } elsif ($vtype eq 'SCALAR') { $child_knot = tied($$v) } next unless $child_knot && $child_knot->{_key_hex}; push @{ $extra_child_keys{$hex} }, $child_knot->{_key_hex}; } } # If called as an object method, restrict output to just that knot's tree # by BFS through both child_keys (JSON) and extra_child_keys (Storable). if ($knot_filter && $knot_filter->{_key_hex}) { my $root_hex = $knot_filter->{_key_hex}; my (%in_tree, @queue); push @queue, $root_hex; while (my $h = shift @queue) { next if $in_tree{$h}++; push @queue, @{ $segs->{$h}{child_keys} // [] }; push @queue, @{ $extra_child_keys{$h} // [] }; } %$segs = map { $_ => $segs->{$_} } grep { $in_tree{$_} } keys %$segs; } # Identify root segments (not a child of any other segment) my %is_child; for my $hex (keys %$segs) { $is_child{$_}++ for @{ $segs->{$hex}{child_keys} }; } for my $hex (keys %extra_child_keys) { next unless exists $segs->{$hex}; $is_child{$_}++ for @{ $extra_child_keys{$hex} }; } my @roots = sort grep { ! $is_child{$_} } keys %$segs; my @lines; push @lines, 'IPC::Shareable Segment Map'; push @lines, '=' x 26; if (! @roots) { push @lines, ''; push @lines, ' (no IPC::Shareable segments found)'; return join("\n", @lines) . "\n"; } my $render; $render = sub { my ($hex, $depth) = @_; my $indent = ' ' x $depth; my $seg = $segs->{$hex} // {}; my @tags; push @tags, $seg->{known} ? 'known' : 'unknown'; push @tags, 'owner' if $seg->{local_process}; my $tag_str = '[' . join(', ', @tags) . ']'; my $seg_id = $id_by_hex{$hex} // '?'; # Read semaphore slot values and ID; for segments not in # global_register attach with nsems=0 (avoids EINVAL on existing sets) my ($sem_str, $content_str); my $sem = $knot_by_hex{$hex} ? $knot_by_hex{$hex}->sem : IPC::Semaphore->new(hex($hex), 0, 0); if (defined $sem) { my $sem_id = $sem->id // '?'; my $marker = $sem->getval(SEM_MARKER) // '?'; my $readers = $sem->getval(SEM_READERS) // '?'; my $writers = $sem->getval(SEM_WRITERS) // '?'; my $protected = $sem->getval(SEM_PROTECTED) // '?'; # Continuation indent: one tab (8 spaces) from the left margin my $cont = ' ' x 8; $sem_str = join("\n", "sem_id: $sem_id", "${cont}1: SEM_MARKER=$marker", "${cont}2: READERS=$readers", "${cont}3: WRITERS=$writers", "${cont}4: PROTECTED=$protected", ); } else { $sem_str = '(not accessible)'; } $content_str = $knot_by_hex{$hex} ? _shm_data_summary($knot_by_hex{$hex}) : '(not accessible - segment not tied in this process)'; # Merge child keys from shm_segments() and from global_register walk my %seen_child; my @child_keys = grep { ! $seen_child{$_}++ } ( @{ $seg->{child_keys} // [] }, @{ $extra_child_keys{$hex} // [] }, ); my $children = @child_keys ? join(', ', @child_keys) : '(none)'; push @lines, ''; push @lines, "${indent}${tag_str} key: ${hex} seg_id: ${seg_id}"; push @lines, "${indent} Semaphores: ${sem_str}"; push @lines, "${indent} Children: ${children}"; push @lines, "${indent} Content: ${content_str}"; $render->($_, $depth + 1) for @child_keys; }; $render->($_, 0) for @roots; push @lines, ''; return join("\n", @lines) . "\n"; } sub sysv_info { shift; # Discard invocant (object ref or class name) my %opts = @_; my $proc_dir = delete $opts{_proc_dir} // '/proc/sys/kernel'; my $sysctl_out = delete $opts{_sysctl_out}; my %info; if ($^O eq 'darwin') { my $out = defined $sysctl_out ? $sysctl_out : do { open my $fh, '-|', 'sysctl', 'kern.sysv' or die "sysctl: $!"; local $/; my $s = <$fh>; close $fh; $s; }; for my $line (split /\n/, $out) { if ($line =~ /^kern\.sysv\.(\w+):\s*(\S+)/) { $info{$1} = $2; } } } elsif ($^O eq 'freebsd' || $^O eq 'midnightbsd' || $^O eq 'netbsd') { # MidnightBSD (FreeBSD-derived) and NetBSD share FreeBSD's kern.ipc # sysctl namespace. NetBSD's semmni also defaults to 10, so exposing # the limit there lets the test suite's free-set guard activate # instead of dying ENOSPC mid-run. my $out = defined $sysctl_out ? $sysctl_out : do { open my $fh, '-|', 'sysctl', 'kern.ipc' or die "sysctl: $!"; local $/; my $s = <$fh>; close $fh; $s; }; for my $line (split /\n/, $out) { if ($line =~ /^kern\.ipc\.((?:shm|sem)\w+)\s*[:=]\s*(\S+)/) { $info{$1} = $2; } } } elsif ($^O eq 'openbsd') { my $out = defined $sysctl_out ? $sysctl_out : do { open my $fh, '-|', 'sysctl', 'kern.seminfo', 'kern.shminfo' or die "sysctl: $!"; local $/; my $s = <$fh>; close $fh; $s; }; for my $line (split /\n/, $out) { if ($line =~ /^kern\.(?:sem|shm)info\.(\w+)\s*=\s*(\S+)/) { $info{$1} = $2; } } } elsif ($^O eq 'linux') { for my $key (qw(shmmax shmmin shmmni shmall)) { my $file = "$proc_dir/$key"; if (open my $fh, '<', $file) { chomp(my $val = <$fh>); $info{$key} = $val; } } # /proc/sys/kernel/sem is a single line of 4 ints: # semmsl semmns semopm semmni if (open my $fh, '<', "$proc_dir/sem") { chomp(my $line = <$fh>); close $fh; my @vals = split /\s+/, $line; if (@vals >= 4) { @info{qw(semmsl semmns semopm semmni)} = @vals[0..3]; } } } return %info ? \%info : undef; } # Cleanup sub clean_up { my $class = shift; for my $id (keys %process_register) { my $s = $process_register{$id}; next unless $s->attributes('owner') == $$; next if $s->attributes('protected'); remove($s); } } sub clean_up_all { my $class = shift; my $global_register = __PACKAGE__->global_register; for my $id (keys %$global_register) { my $s = $global_register->{$id}; next if $s->attributes('protected'); remove($s); } } sub clean_up_protected { my ($knot, $protect_key); if (scalar @_ == 2) { ($knot, $protect_key) = @_; } if (scalar @_ == 1) { ($protect_key) = @_; } if (! defined $protect_key) { croak "clean_up_protected() requires a \$protect_key param"; } if ($protect_key !~ /^\d+$/) { croak "clean_up_protected() \$protect_key must be an integer. You sent $protect_key"; } my $global_register = __PACKAGE__->global_register; for my $id (keys %$global_register) { my $s = $global_register->{$id}; my $stored_key = $s->attributes('protected'); if ($stored_key && $stored_key == $protect_key) { remove($s); } } } sub remove { my ($knot, $key) = @_; # If a key is passed, remove that specific segment by key rather than # via an existing tied object if (defined $key) { $key = $knot->_shm_key($key); my $id = shmget($key, 0, 0); if (! defined $id) { warn "remove(): shmget failed for key $key: $!"; return; } if (! shmctl($id, IPC_RMID, 0)) { warn "Couldn't remove shm segment $id: $!"; } else { delete $process_register{$id}; delete $global_register{$id}; } # Remove the associated semaphore set (same key, attach-only with nsems=0) my $sem = IPC::Semaphore->new($key, 0, 0); if (defined $sem) { $sem->remove or warn "Couldn't remove semaphore set for key $key: $!"; } return; } # Standard object based removal my $seg = $knot->seg; my $id = $seg->id; my $seg_removed = 0; if (! $seg->remove) { warn "Couldn't remove shm segment $id: $!"; } else { $seg_removed = 1; } # Semaphore cleanup my $sem = $knot->sem; my $sem_removed = 0; my $sem_remove_status = $sem->remove; if ($sem_remove_status != 1 && $sem_remove_status ne '0 but true') { warn "Couldn't remove semaphore set $id: $!"; } else { $sem_removed = 1; } # If the segment or semaphore couldn't be cleaned up, we need to # keep state if ($seg_removed && $sem_removed) { delete $process_register{$id}; delete $global_register{$id}; } } # Unit testing sub testing_set { my ($class, $dist_name) = @_; croak "testing_set() requires a distribution name string" unless defined $dist_name && length $dist_name; $_testing_dist = $dist_name; } sub clean_up_testing { shift if @_ > 1 && ! ref $_[0] && defined $_[0] && UNIVERSAL::isa($_[0], __PACKAGE__); my ($dist_name) = @_; croak "clean_up_testing() requires a distribution name string" unless defined $dist_name && length $dist_name; my $target = _testing_semaphore_key_hash($dist_name); my $removed = 0; # Scan ipcs -m for segment IDs and keys directly. We cannot use # shm_segments() here because it filters by the 'IPC::Shareable' 14-byte # tag, which is only written during STORE operations — empty tied segments # have no tag and would be invisible. The authoritative identifier for a # testing-tagged segment is the SEM_TESTING value on its semaphore set, # not the segment content. open my $ipcs_fh, '-|', 'ipcs', '-m' or die "ipcs -m: $!"; while (my $line = <$ipcs_fh>) { my ($id, $raw_key); if ($line =~ /^\s*m\s+(\d+)\s+(\S+)/) { # BSD/macOS: m ... ($id, $raw_key) = ($1, $2); } elsif ($line =~ /^\s*(\d+)\s+(0x[0-9a-fA-F]+)\s+/) { # DragonFly BSD: ... (no type-letter column) ($id, $raw_key) = ($1, $2); } elsif ($line =~ /^\s*(\S+)\s+(\d+)\s+\S+/) { # Linux: ... ($raw_key, $id) = ($1, $2); } else { next; } my $key_int = $raw_key =~ /^0x[0-9a-fA-F]+$/ ? hex($raw_key) : $raw_key =~ /^-?\d+$/ ? int($raw_key) : next; # IPC_PRIVATE segments cannot be re-attached across processes next if $key_int == 0; my $sem = IPC::Semaphore->new($key_int, 0, 0); next unless defined $sem; next unless _testing_semaphore_value($sem) == $target; # Don't tear down a segment another *live* process owns -- eg. a sibling # test file under `prove -j`, or a concurrent smoker testing the same # dist. Segments this process created ($cpid == $$), and orphans whose # creator process has exited, are still removed. my $probe = bless {}, 'IPC::Shareable::SharedMem'; $probe->id($id); my $stat = eval { $probe->stat }; my $cpid = defined $stat ? $stat->cpid : undef; next if defined $cpid && $cpid > 0 && $cpid != $$ && kill 0, $cpid; if (shmctl($id, IPC_RMID, 0)) { $sem->remove; delete $process_register{$id}; delete $global_register{$id}; $removed++; } else { warn "clean_up_testing(): could not remove shm segment $id: $!"; } } close $ipcs_fh; # Second pass: reclaim orphaned testing-tagged semaphore sets -- ones whose # shm segment is already gone (eg. a crashed run died between removing the # segment and removing its semaphore set). The first pass cannot see these # because it walks ipcs -m. Each orphan pins a SEMMNI slot forever, and on # hosts with a tiny limit (OpenBSD defaults to kern.seminfo.semmni=10) the # accumulation eventually starves every subsequent semget() into ENOSPC -- # the mass CPAN tester failure mode. A tagged set whose segment is gone can # never be re-attached by _tie() (the segment is always created before the # semaphore set), so removing it is race-free. open $ipcs_fh, '-|', 'ipcs', '-s' or die "ipcs -s: $!"; while (my $line = <$ipcs_fh>) { my $raw_key; if ($line =~ /^\s*s\s+\d+\s+(\S+)/) { # BSD/macOS: s ... $raw_key = $1; } elsif ($line =~ /^\s*\d+\s+(0x[0-9a-fA-F]+)\s+/) { # DragonFly BSD: ... (no type-letter column) $raw_key = $1; } elsif ($line =~ /^\s*(\S+)\s+\d+\s+\S+/) { # Linux: ... $raw_key = $1; } else { next; } my $key_int = $raw_key =~ /^0x[0-9a-fA-F]+$/ ? hex($raw_key) : $raw_key =~ /^-?\d+$/ ? int($raw_key) : next; next if $key_int == 0; # A live segment means a healthy (or first-pass handled) pair next if defined shmget($key_int, 0, 0); my $sem = IPC::Semaphore->new($key_int, 0, 0); next unless defined $sem; next unless _testing_semaphore_value($sem) == $target; $removed++ if $sem->remove; } close $ipcs_fh; return $removed; } # Private methods # Encoding/Decoding sub _encode { my ($knot, $seg, $data) = @_; # A scalar tie() holding a plain (defined, non-ref) value is stored verbatim # in a single segment — no serializer wrapping or escaping. Automatic and # serializer-agnostic; refs and undef fall through to the configured # serializer (refs fan out / freeze; undef → {"__sv__":null} / storable). if ($knot->{_type_int} == TYPE_SCALAR && ref($data) eq 'SCALAR') { my $val = $$data; if (defined $val && ! ref $val) { return _encode_verbatim($seg, $val); } } my $serializer = $knot->attributes('serializer'); if ($serializer eq 'storable') { return _freeze($seg, $data); } return _encode_json($seg, $data); } sub _decode { my ($knot, $seg) = @_; # A scalar tie's value may have been stored verbatim (tag + \x1e sentinel); # recognize that and short-circuit before serializer dispatch, regardless of # json/storable. if ($knot->{_type_int} == TYPE_SCALAR) { my $verbatim = _decode_verbatim($seg); return $verbatim if defined $verbatim; } my $serializer = $knot->attributes('serializer'); my $data = $serializer eq 'storable' ? _thaw($seg) : _decode_json($seg, $knot); return $data if defined $data; # Empty/never-written segment — return appropriate empty default so that # aggregate tie methods (FETCHSIZE, PUSH, CLEAR, etc.) can deref safely. return [] if $knot->{_type_int} == TYPE_ARRAY; return {} if $knot->{_type_int} == TYPE_HASH; return undef; } sub _encode_json { my $seg = shift; my $data = shift; my $json = encode_json _encode_json_prepare($data); substr $json, 0, 0, 'IPC::Shareable'; if (length($json) > $seg->size) { croak "Length of shared data exceeds shared segment size"; } $seg->shmwrite($json); } sub _encode_json_prepare { my ($data) = @_; my $type = Scalar::Util::reftype($data) or return $data; # Replace direct IPC::Shareable child segments with __ics__ markers. # All nested refs are tied children — no recursion needed; each child # segment encodes its own children independently. We have to do this because # JSON can't store blessed objects if ($type eq 'HASH') { { my $has_child = 0; for my $val (values %$data) { if (ref($val) && _is_child($val)) { $has_child = 1; last; } } return $data if ! $has_child; } my %result; for my $key (keys %$data) { my $val = $data->{$key}; my $inner = ref($val) && _is_child($val); $result{$key} = $inner ? { '__ics__' => { type => $inner->{_type}, child_key => $inner->{_key}, child_key_hex => sprintf('0x%08x', $inner->{_key}) } } : $val; } return \%result; } if ($type eq 'ARRAY') { { my $has_child = 0; for my $val (@$data) { if (ref($val) && _is_child($val)) { $has_child = 1; last; } } return $data if ! $has_child; } return [ map { my $inner = ref($_) && _is_child($_); $inner ? { '__ics__' => { type => $inner->{_type}, child_key => $inner->{_key}, child_key_hex => sprintf('0x%08x', $inner->{_key}) } } : $_ } @$data ]; } if ($type eq 'SCALAR' || $type eq 'REF') { my $val = $$data; my $inner = ref($val) && _is_child($val); return $inner ? { '__ics__' => { type => $inner->{_type}, child_key => $inner->{_key}, child_key_hex => sprintf('0x%08x', $inner->{_key}) } } : { '__sv__' => $val }; } return $data; } sub _decode_json { my ($seg, $knot) = @_; my $json = $seg->data; return if ! $json; # The return of shmread() is the actual size of the defined size of the # shared memory segment. Even if the return equates to an empty string # (which it will if it contains no data), there will always be a length(). # Therefore, we must see if we've tagged this data as a valid structure, # or else decode will fail my $tag = substr $json, 0, 14, ''; if ($tag eq 'IPC::Shareable') { my $data = decode_json $json; if (! defined($data)) { croak "Munged shared memory segment (size exceeded?)"; } if (defined $knot && index($json, '"__ics__"') >= 0) { _decode_json_restore($data, $knot) } # Unwrap scalar-tie values encoded as { '__sv__' => val } or # { '__ics__' => {...} } if (defined $knot && $knot->{_type_int} == TYPE_SCALAR && ref($data) eq 'HASH') { if (exists $data->{'__ics__'}) { my $prev = $knot->{_data}; my $prev_val = (defined $prev && ref($prev)) ? $$prev : undef; my $resolved = _decode_json_resolve($data->{'__ics__'}, $prev_val, $knot); return \$resolved; } if (exists $data->{'__sv__'}) { my $val = $data->{'__sv__'}; return \$val; } } return $data; } else { return; } } sub _decode_json_restore { my ($data, $knot) = @_; my $type = Scalar::Util::reftype($data) or return; # Reuse existing tied child refs from previous decode where possible. # This avoids a shmget+semget system call pair for each child on every # decode cycle — only the first attach per segment incurs that cost. my $prev = $knot->{_data}; if ($type eq 'HASH') { my $prev_is_hash = ref($prev) eq 'HASH'; for my $key (keys %$data) { next unless ref($data->{$key}) eq 'HASH' && exists $data->{$key}{'__ics__'}; $data->{$key} = _decode_json_resolve( $data->{$key}{'__ics__'}, $prev_is_hash ? $prev->{$key} : undef, $knot, ); } } elsif ($type eq 'ARRAY') { my $prev_is_array = ref($prev) eq 'ARRAY'; my $prev_max = $prev_is_array ? $#$prev : -1; for my $i (0 .. $#$data) { next unless ref($data->[$i]) eq 'HASH' && exists $data->[$i]{'__ics__'}; $data->[$i] = _decode_json_resolve( $data->[$i]{'__ics__'}, $prev_is_array && $i <= $prev_max ? $prev->[$i] : undef, $knot, ); } } } sub _decode_json_resolve { my ($info, $existing, $knot) = @_; if (defined $existing) { my $inner = ref($existing) && _is_child($existing); return $existing if $inner && $inner->{_key} == $info->{child_key}; } return _decode_json_reattach($info, $knot); } sub _decode_json_reattach { my ($info, $knot) = @_; my %opts = ( %{ $knot->attributes }, key => $info->{child_key}, exclusive => 0, create => 0, magic => 1, ); if ($info->{type} eq 'HASH') { my %h; tie %h, 'IPC::Shareable', \%opts; return \%h; } elsif ($info->{type} eq 'ARRAY') { my @a; tie @a, 'IPC::Shareable', \%opts; return \@a; } elsif ($info->{type} eq 'SCALAR') { my $s; tie $s, 'IPC::Shareable', \%opts; return \$s; } } sub _encode_verbatim { my ($seg, $val) = @_; # Store a plain scalar verbatim. Layout: the 14-byte 'IPC::Shareable' tag # (so shm_segments()/clean_up_testing still recognize the segment as ours), # a one-byte \x1e sentinel marking "not serialized — hand these bytes back # as-is", then the caller's bytes. The sentinel lets _decode tell this from # a json {…} body or a storable header. The caller (_encode) guarantees # $val is a defined, non-ref scalar. my $raw = "IPC::Shareable\x1e" . $val; if (length($raw) > $seg->size) { croak "Length of shared data exceeds shared segment size"; } $seg->shmwrite($raw); } sub _decode_verbatim { my ($seg) = @_; # Recognize a verbatim scalar segment: the 14-byte 'IPC::Shareable' tag # followed by the \x1e sentinel. Return a scalar ref to the bytes after the # sentinel — trailing NUL padding stripped, internal NULs preserved. Return # undef for anything else (a json {…}/[…] body, a storable body, or an # empty/never-written segment) so _decode falls through to the serializer. my $raw = $seg->shmread; return if ! defined $raw; $raw =~ s/\x00+$//; return if substr($raw, 0, 15) ne "IPC::Shareable\x1e"; my $payload = substr($raw, 15); return \$payload; } sub _freeze { my ($seg, $water) = @_; my $ice = freeze $water; croak "Could not serialize data for shared memory" unless defined $ice; substr $ice, 0, 0, 'IPC::Shareable'; if (length($ice) > $seg->size) { croak "Length of shared data exceeds shared segment size"; } $seg->shmwrite($ice); } sub _thaw { my ($seg) = @_; my $ice = $seg->shmread; return if ! $ice; my $tag = substr $ice, 0, 14, ''; if ($tag eq 'IPC::Shareable') { my $water = thaw $ice; if (! defined($water)) { croak "Munged shared memory segment (size exceeded?)"; } return $water; } else { return; } } # Data management sub _tie { my ($type, $class, $key_str, $opts); if (scalar @_ == 4) { # Legacy API allowed a string scalar key ($type, $class, $key_str, $opts) = @_; $opts->{key} = $key_str; } else { ($type, $class, $opts) = @_; } $opts = _parse_args($opts); my $knot = bless { attributes => $opts }, $class; $knot->uuid; my $key = $knot->_shm_key; my $flags = $knot->_shm_flags; my $shm_size = $knot->attributes('size'); if ($knot->attributes('limit') && $shm_size > SHMMAX_BYTES) { croak "Shared memory segment size '$shm_size' is larger than max size of " . SHMMAX_BYTES; } my $seg; if ($knot->attributes('graceful')) { my $exclusive = eval { $seg = IPC::Shareable::SharedMem->new( key => $key, size => $shm_size, flags => $flags, mode => $knot->attributes('mode'), type => $type, ); 1; }; if (! defined $exclusive) { if ($knot->attributes('warn')) { my $key = lc(sprintf("0x%X", $knot->_shm_key)); warn "Process ID $$ exited due to exclusive shared memory collision at segment/semaphore key '$key'\n"; } exit(0); } } else { $seg = IPC::Shareable::SharedMem->new( key => $key, size => $shm_size, flags => $flags, mode => $knot->attributes('mode'), type => $type, ); } if (! defined $seg) { if ($!{ENOMEM}) { croak "\nERROR: Could not create shared memory segment: $!\n\n" . "Are you using too large a segment size, or spawning too many segments?"; } if ($!{ENOSPC}) { croak "\nERROR: Could not create shared memory segment: $!\n\n" . "Are you spawning too many segments (in a loop perhaps)?"; } if (! $knot->attributes('create')) { confess "ERROR: Could not acquire shared memory segment... 'create' ". "option is not set, and the segment hasn't been created " . "yet:\n\n $!"; } elsif ($knot->attributes('create') && $knot->attributes('exclusive')) { croak "ERROR: Could not create shared memory segment. 'create' " . "and 'exclusive' are set. Does the segment already exist? " . "\n\n$!"; } else { croak "ERROR: Could not create shared memory segment.\n\n$!"; } } # Try to attach to an existing semaphore set first using nsems=0, which # avoids EINVAL on macOS/BSD when the existing set has fewer slots than # the requested count. If the set does not exist yet, fall through to # create a new semaphore set: 5 slots when the 'testing' attribute is set # (adds SEM_TESTING at index 4), 4 slots otherwise. my $nsems = $knot->attributes('testing') ? 5 : 4; my $sem = IPC::Semaphore->new($key, 0, $seg->flags & 0777) // IPC::Semaphore->new($key, $nsems, $seg->flags); if (! defined $sem) { # The segment was created just above, but we couldn't establish its # semaphore set (eg. ENOSPC when the host's semaphore limit is hit). # Remove the segment we just made so it isn't orphaned -- but only when # we are the creator: a pure attacher (create => 0) must never remove a # segment that another process owns. An IPC_PRIVATE segment is always # freshly created by shmget() regardless of the 'create' attribute, and # is unreachable by key once we croak, so it must be removed too -- it # would otherwise leak invisibly (clean_up_testing() cannot see key 0). # Preserve $! across the removal so the croak still reports the # original failure (eg. "No space left on device") rather than the # result of the cleanup's shmctl. my $err = $!; $seg->remove if $knot->attributes('create') || $key == IPC_PRIVATE; $! = $err; croak "Could not create semaphore set: $!\n"; } if (! $sem->op(@{ $semop_args{(LOCK_SH)} }) ) { # Lock acquisition failed before the knot was registered, so nothing # else will reclaim these. Tear down what we just made: the semaphore # set if we created it (its marker isn't set yet), and the segment if # we are its creator (an IPC_PRIVATE segment is always freshly created, # and unreachable by key hereafter, so it counts as ours too). # Preserve $! so the croak still names the cause. my $err = $!; $sem->remove if $sem->getval(SEM_MARKER) != SHM_EXISTS; $seg->remove if $knot->attributes('create') || $key == IPC_PRIVATE; $! = $err; croak "Could not obtain semaphore set lock: $!\n"; } %$knot = ( %$knot, _hkey_list => undef, _key => $key, _key_hex => $seg->key_hex, _lock => 0, _shm => $seg, _sem => $sem, _type => $type, _type_int => $type eq 'HASH' ? TYPE_HASH : $type eq 'ARRAY' ? TYPE_ARRAY : TYPE_SCALAR, _was_changed => 0, ); my $serializer = $knot->attributes('serializer'); if ($serializer eq 'json') { my $data; my $decoded_ok = eval { $data = $knot->_decode($seg); 1 }; if (! $decoded_ok) { # JSON decode threw; the segment may contain legacy Storable data. # Try Storable; if it succeeds, silently switch this session over # and warn the caller so they know to migrate. my $storable_data; my $thaw_ok = eval { $storable_data = _thaw($seg); 1 }; if ($thaw_ok && defined $storable_data) { carp sprintf( "IPC::Shareable: segment 0x%08x contains Storable-encoded data; " . "switching serializer to 'storable' for this session. " . "Re-create the segment to migrate it to JSON.", $key ); $knot->{attributes}{serializer} = 'storable'; $knot->{_data} = $storable_data; } else { die $@; } } else { $knot->{_data} = $data; } } else { $knot->{_data} = $knot->_decode($seg); } # Register unconditionally so any process that attaches to an existing # segment (create=>0, re-attach, cross-process) is also tracked for # clean_up_all(). Previously only new segments were registered here, # requiring the Dumper hack in global_register() to catch the rest if (! exists $global_register{$knot->seg->id}) { $global_register{$knot->seg->id} = $knot; } if ($sem->getval(SEM_MARKER) != SHM_EXISTS) { $process_register{$knot->seg->id} ||= $knot; $sem->setval(SEM_PROTECTED, $knot->attributes('protected')); if ($knot->attributes('testing')) { $sem->setval(SEM_TESTING, _testing_semaphore_key_hash($knot->attributes('testing'))); } if (! $sem->setval(SEM_MARKER, SHM_EXISTS)) { croak "Couldn't set semaphore during object creation: $!"; } } else { # Segment already existed — restore the protected and testing # attributes from the semaphore so that clean_up_all() / clean_up_testing() # in this process work correctly even when the caller did not explicitly # pass them on tie. my $stored_protected = $sem->getval(SEM_PROTECTED); if (defined $stored_protected && $stored_protected != 0) { $knot->{attributes}{protected} = $stored_protected } my $stored_testing = _testing_semaphore_value($sem); if ($stored_testing) { $knot->{attributes}{testing} = $stored_testing; } } $sem->op(@{ $semop_args{(LOCK_SH|LOCK_UN)} }); return $knot; } sub _magic_tie { my ($parent, $val) = @_; my $key; if ($parent->{_key} == IPC_PRIVATE && $parent->attributes('serializer') ne 'json') { $key = IPC_PRIVATE; } else { $key = _shm_key_rand(); } # The individual options in the hash override any pre-set options that are # being inherited from the parent my %opts = ( %{ $parent->attributes }, key => $key, exclusive => 1, create => 1, magic => 1, ); # XXX I wish I didn't have to take a copy of data here and copy it back in # XXX Also, have to peek inside potential objects to see their implementation my $child; my $type = Scalar::Util::reftype($val) || ''; if ($type eq "HASH") { my %copy = %$val; $child = tie %$val, 'IPC::Shareable', $key, { %opts }; croak "Could not create inner tie" if ! $child; %$val = %copy; } elsif ($type eq "ARRAY") { my @copy = @$val; $child = tie @$val, 'IPC::Shareable', $key, { %opts }; croak "Could not create inner tie" if ! $child; @$val = @copy; } elsif ($type eq "SCALAR") { my $copy = $$val; $child = tie $$val, 'IPC::Shareable', $key, { %opts }; croak "Could not create inner tie" if ! $child; $$val = $copy; } else { croak "Variables of type $type not implemented"; } return $child; } sub _need_tie { my ($knot, $val) = @_; my $type = Scalar::Util::reftype($val); return 0 if ! $type; my $need_tie; if ($type eq "HASH") { $need_tie = ! (tied %$val); } elsif ($type eq "ARRAY") { $need_tie = ! (tied @$val); } elsif ($type eq "SCALAR") { $need_tie = ! (tied $$val); } return $need_tie ? 1 : 0; } sub _remove_child { my ($val) = @_; if (ref($val) && (my $child = _is_child($val))) { $child->remove; } } sub _is_child { return $_have_xs ? _is_child_xs($_[0]) : _is_child_pp($_[0]); } sub _is_child_pp { my $data = shift or return; my $type = Scalar::Util::reftype( $data ); return unless $type; my $obj; if ($type eq "HASH") { $obj = tied %$data; } elsif ($type eq "ARRAY") { $obj = tied @$data; } elsif ($type eq "SCALAR") { $obj = tied $$data; } if (ref $obj eq 'IPC::Shareable') { return $obj; } return; } sub _write_to_seg { my ($knot) = @_; my $seg_id = $knot->seg->id; if (! defined $knot->_encode($knot->seg, $knot->{_data})) { croak "Could not write to shared memory segment $seg_id: $!"; } } # Segment/semaphore operations sub _execute_lock_coderef { my ($knot, $code) = @_; my $ok = eval { $code->(); 1 }; my $err = $@; $knot->unlock; die $err if ! $ok; } sub _key_str_to_int { # Convert any key format (hex string, decimal integer string, or arbitrary # text) to a 32-bit integer using the same algorithm as _shm_key(), but # without the %used_ids side effect. Safe to call any number of times. my ($key_str) = @_; return hex($key_str) if $key_str =~ /^0x[0-9a-fA-F]+$/i; return $key_str + 0 if $key_str =~ /^\d+$/; my $int = crc32($key_str); $int -= MAX_KEY_INT_SIZE if $int > MAX_KEY_INT_SIZE; return $int; } sub _lock_children { my ($root_knot, $flags) = @_; my @locked; my %seen = ($root_knot->seg->id => 1); my @stack = ([$root_knot, 0]); while (@stack) { my $frame = $stack[-1]; my ($knot, $idx) = @$frame; my $data = $knot->{_data}; my $rtype = Scalar::Util::reftype($data) // ''; my @vals = $rtype eq 'HASH' ? values %$data : $rtype eq 'ARRAY' ? @$data : (); my $found = 0; for (my $i = $idx; $i < @vals; $i++) { my $val = $vals[$i]; next unless ref($val); my $child = _is_child($val); next unless $child && $child->seg; my $id = $child->seg->id; next if $seen{$id}++; if (! $child->sem->op(@{ $semop_args{$flags} })) { for my $locked (reverse @locked) { my $rflags = $locked->{_lock} | LOCK_UN; $rflags ^= LOCK_NB if $rflags & LOCK_NB; $locked->sem->op(@{ $semop_args{$rflags} }); $locked->{_lock} = 0; } return; } $child->{_data} = $child->_decode($child->seg); $child->{_lock} = $flags; push @locked, $child; $frame->[1] = $i + 1; push @stack, [$child, 0]; $found = 1; last; } pop @stack unless $found; } return \@locked; } sub _shm_data_summary { my ($knot) = @_; my $data = $knot->{_data}; my $rtype = Scalar::Util::reftype($data) // ''; if ($rtype eq 'SCALAR') { my $v = $$data; return defined $v ? qq("$v") : '(undef)'; } if ($rtype eq 'HASH') { my @parts; for my $k (sort keys %$data) { my $v = $data->{$k}; if (ref $v) { my $vt = Scalar::Util::reftype($v) // ''; my $child = $vt eq 'HASH' ? tied(%$v) : $vt eq 'ARRAY' ? tied(@$v) : $vt eq 'SCALAR' ? tied($$v) : undef; push @parts, $child && $child->{_key_hex} ? qq($k => {_key_hex}>) : "$k => "; } else { push @parts, defined $v ? qq($k => "$v") : "$k => (undef)"; } } return @parts ? '{ ' . join(', ', @parts) . ' }' : '{}'; } if ($rtype eq 'ARRAY') { my @parts; for my $v (@$data) { if (ref $v) { my $vt = Scalar::Util::reftype($v) // ''; my $child = $vt eq 'HASH' ? tied(%$v) : $vt eq 'ARRAY' ? tied(@$v) : $vt eq 'SCALAR' ? tied($$v) : undef; push @parts, $child && $child->{_key_hex} ? "{_key_hex}>" : ''; } else { push @parts, defined $v ? qq("$v") : '(undef)'; } } return '[' . join(', ', @parts) . ']'; } return '(unknown type)'; } sub _shm_flags { # Parses the anonymous hash passed to constructors; returns a list # of args suitable for passing to shmget my ($knot) = @_; my $flags = 0; $flags |= IPC_CREAT if $knot->attributes('create'); $flags |= IPC_EXCL if $knot->attributes('exclusive'); return $flags; } sub _shm_key { # Generates a 32-bit CRC on the key string. The $key_str parameter is used # for testing only, for purposes of testing various key strings my ($knot, $key_str) = @_; $key_str //= ($knot->attributes('key') || ''); my $key; if ($key_str eq '') { $key = IPC_PRIVATE; } elsif ($key_str =~ /^0x[0-9a-fA-F]+$/i) { # User specified an explicit hex string key (eg. '0xDEADBEEF'); use the # bit pattern as-is so the segment key seen by ipcs(1) matches exactly. $key = hex($key_str); $used_ids{$key}++; return $key; } elsif ($key_str =~ /^\d+$/) { # User specified an explicit decimal integer key; use it as-is. $key = $key_str; $used_ids{$key}++; return $key; } else { # String key: compute a 32-bit CRC and apply overflow correction so the # result fits in a signed 32-bit key_t. $key = crc32($key_str); } $used_ids{$key}++; if ($key >= MAX_KEY_INT_SIZE) { $key = $key - MAX_KEY_INT_SIZE; if ($key == 0) { croak "We've calculated a key which equals 0. This is a fatal error"; } } return $key; } sub _shm_key_rand { my $key; # Unfortunately, the only way I know how to check if a segment exists is # to actually create it. We must do that here, then remove it just to # ensure the slot is available my $verified_exclusive = 0; my $check_count = 0; while (! $verified_exclusive && $check_count < EXCLUSIVE_CHECK_LIMIT) { $check_count++; $key = _shm_key_rand_int(); next if $used_ids{$key}; my $flags; $flags |= IPC_CREAT; $flags |= IPC_EXCL; my $seg; my $shm_slot_available = eval { $seg = IPC::Shareable::SharedMem->new( key => $key, size => 1, flags => $flags, ); 1; }; if ($shm_slot_available) { $verified_exclusive = 1; $seg->remove if $seg; } } if (! $verified_exclusive) { croak "_shm_key_rand() can't get an available key after $check_count tries"; } $used_ids{$key}++; return $key; } sub _shm_key_rand_int { return int(rand(1_000_000)); } sub _read_check { my ($knot) = @_; # Advisory only: never blocks the read, only warns. Called from FETCH # when this knot is unlocked (a locked FETCH uses _data cache and never # touches shmem). Race window exists between this getval() and the # subsequent _decode() — a writer could acquire in between — but this # still catches the common case where a reader forgot to lock. return unless $knot->attributes('enforced_read_locking'); return unless $knot->attributes('violated_read_lock_warn'); # getval() can return undef if the semaphore set has been removed (eg. # after clean_up_all). The check is advisory only, so silently skip when # the semaphore is no longer reachable. my $writers = $knot->sem->getval(SEM_WRITERS); return unless defined $writers; if ($writers > 0) { my $uuid = $knot->uuid; my $seg_id = $knot->seg->id; warn "Object with UUID $uuid attempted read from segment ID " . "$seg_id which is exclusively locked (enforced read locking " . "enabled); returned data may be stale or partially-written. " . "Acquire LOCK_SH before reading to guarantee a coherent snapshot"; } return; } sub _write_permitted { my ($knot) = @_; return 1 unless $knot->attributes('enforced_write_locking'); # If this knot itself holds LOCK_EX it is the owner of the lock and is # permitted to write. return 1 if $knot->{_lock} & LOCK_EX; my $sem = $knot->sem; # Semaphore index 2 is the write-lock counter; it is 1 when any other knot # holds LOCK_EX (set via SEM_UNDO so it auto-releases on process exit). # getval() returns undef if the semaphore set has been removed by another # process (eg. clean_up_all, or a peer with destroy=>1 exiting). The # enforcement check is advisory, so when the set is unreachable we skip it # and permit the write, mirroring _check_read_lock(). # Block if any process holds LOCK_EX my $writers = $sem->getval(SEM_WRITERS); return 1 if ! defined $writers; if ($writers > 0) { if ($knot->attributes('violated_write_lock_warn')) { my $uuid = $knot->uuid; my $seg_id = $knot->seg->id; warn "Object with UUID $uuid attempted write to segment ID " . "$seg_id which is exclusively locked (enforced write " . "locking enabled). Your write was not accepted. Lock with " . "LOCK_EX to ensure successful writes when a segment is " . "already locked"; } return 0; } # Block if any process holds LOCK_SH (active readers present) my $readers = $sem->getval(SEM_READERS); return 1 if ! defined $readers; if ($readers > 0) { if ($knot->attributes('violated_write_lock_warn')) { my $uuid = $knot->uuid; my $seg_id = $knot->seg->id; warn "Object with UUID $uuid attempted write to segment ID " . "$seg_id which has active readers (enforced write locking " . "enabled)"; } return 0; } return 1; } # Unit testing support sub _testing_semaphore_key_hash { my ($dist_name) = @_; # SysV SEMVMX caps semaphore values at 32767 on most platforms (incl. # macOS, BSD); mask the CRC32 to 15 bits so setval() never silently fails. # 0 is reserved to mean "not a testing segment", so we shift any zero # collision off slot 0. my $h = String::CRC32::crc32($dist_name) & 0x7FFF; return $h || 1; } sub _testing_semaphore_value { my ($sem) = @_; my $stat = $sem->stat or return 0; return 0 if $stat->nsems < 5; return $sem->getval(SEM_TESTING) // 0; } # Misc sub _parse_args { my ($opts) = @_; $opts = defined $opts ? $opts : { %default_options }; # Note caller's explicit intent BEFORE defaults are merged in. A caller # who passes testing => 0 wants to opt out of auto-tagging; we must not # treat that as "absent" after defaulting. my $testing_explicit = exists $opts->{testing}; for my $k (keys %default_options) { if (not defined $opts->{$k}) { $opts->{$k} = $default_options{$k}; } elsif ($opts->{$k} eq 'no') { if ($^W) { require Carp; Carp::carp("Use of `no' in IPC::Shareable args is obsolete"); } $opts->{$k} = 0; } } # Validate the serializer selection. 'json' (default) and 'storable' are the # only user-selectable options my $serializer = $opts->{serializer}; if ($serializer ne 'json' && $serializer ne 'storable') { croak "Invalid 'serializer' value '$serializer'; must be 'json' or 'storable'"; } $opts->{owner} = ($opts->{owner} or $$); $opts->{magic} = ($opts->{magic} or 0); # Inherit the process-level testing tag set by testing_set(), unless the # caller explicitly passed a testing value (including testing => 0) if ($_testing_dist && ! $testing_explicit) { $opts->{testing} = $_testing_dist; } return $opts; } sub _end { for my $s (values %process_register) { eval { unlock($s) }; next if $s->attributes('protected'); next if ! $s->attributes('destroy'); next if $s->attributes('owner') != $$; eval { remove($s) }; } } END { _end(); } sub _placeholder {} 1; __END__ =head1 NAME IPC::Shareable - Use shared memory backed variables across processes =for html Coverage Status =head1 SYNOPSIS use IPC::Shareable qw(:lock); tie my %hash, 'IPC::Shareable', OPTIONS; tie my @array, 'IPC::Shareable', OPTIONS; tie my $scalar, 'IPC::Shareable', OPTIONS; # Lock, make changes, unlock tied(VARIABLE)->lock; # Do something with the variable tied(VARIABLE)->unlock; # Blocking lock attempt (a writer must have a LOCK_EX lock) tied(VARIABLE)->lock(LOCK_SH); my $val = VARIABLE->[5]; # Will wait to get value until writer releases LOCK_EX # Non-blocking lock attempt tied(VARIABLE)->lock(LOCK_SH|LOCK_NB) or print "Resource unavailable\n"; # Lock with a code reference, which will auto-unlock when the block finishes tied(VARIABLE)->lock(sub { print "hello!\n"; }); # Ensure only one instance of a script can be run at any time IPC::Shareable->singleton('UNIQUE SCRIPT LOCK STRING'); =head1 SYNOPSIS - DEVELOPER/TROUBLESHOOTING # Get SYSV shared memory specifications of the system (if available) my $href = IPC::Shareable::sysv_info(); # Get the shared memory segment and semaphore objects directly my $segment = tied(VARIABLE)->seg; my $semaphore = tied(VARIABLE)->sem; # Get the shared memory segment and semaphores for a lower level my $seg = tied(%{ $hv{a}->{b} })->seg; my $sem = tied(%{ $hv{a}->{b} })->sem; # Fetch a printable string representation of the segment and semaphore # mapping for your data my $shm_map = tied(VARIABLE)->seg_map; # Remove the shared memory segment and semaphore directly tied(VARIABLE)->remove; # Manual cleanup procedures (mainly used for unit testing etc) IPC::Shareable::clean_up; IPC::Shareable::clean_up_all; IPC::Shareable::clean_up_protected; # In the first test file that runs, purge any leaked segments that remain IPC::Shareable::clean_up_testing('My::Distribution'); # Then in every test file that ties a segment, add: IPC::Shareable->testing_set('My::Distribution'); # Get the actual IPC::Shareable tied object you can make method calls on # instead of using the tied object like the examples above my $knot = tied(VARIABLE); # Dereference first if using a tied reference # ...or get the knot at inception my $knot = tie my VARIABLE, 'IPC::Shareable', OPTIONS; my $sysv_info_href = $knot->sysv_info; =head1 DESCRIPTION IPC::Shareable allows you to tie a variable to shared memory, making it easy to share the contents of that variable with other Perl processes and scripts. Scalars, arrays, hashes and even objects can be tied. The variable being tied may contain arbitrarily complex data structures - including references to arrays, hashes of hashes, etc. B: When using nested data structures, each nested structure utilizes an additional shared memory segment. The entire structure is not squashed into a single segment. See L for details. The association between variables in distinct processes is provided by GLUE (aka. a "key"). This is any arbitrary string or integer that serves as a common identifier for data across process space. Hence the statement: tie my %hash, 'IPC::Shareable', { key => 'GLUE STRING', create => 1 }; ...in program one and the statement tie my %thing, 'IPC::Shareable', { key => 'GLUE STRING' }; ...in program two will create and bind C<%hash> the shared memory in program one and bind it to C<%thing> in program two. There is no pre-set limit to the number of processes that can bind to data; nor is there a pre-set limit to the complexity of the underlying data of the tied variables. The amount of data that can be shared within a single bound variable is limited by the system's maximum size for a shared memory segment, and the total number of segments allowed by the system (the exact values are system-dependent). The bound data structures are all linearized (using L by default or optionally L) before being slurped into shared memory. Upon retrieval, the original format of the data structure is recovered. Semaphore flags can be used for locking data between competing processes. B: A tied scalar can store arbitrary data. If you send in plain data, you get plain data back; if you encode it yourself (eg. with L), it is up to you to decode it. Storing a B shares the referenced structure, the same as tying a hash or array. B: Utilizing the locking mechanisms is highly advised to ensure data consistency and integrity. See L. B: If you're using JSON to serialize your data (the default), I would highly advise you to install the XS version (L). We will automatically use it if available, and it is much faster than the pure Perl version (L). =head1 OPTIONS Options are specified by passing a reference to a hash as the third argument to the C function that binds a variable. We also call these B. The following fields are recognized in the options hash: =head2 key B is the GLUE that is a direct reference to the shared memory segment that's to be tied to the variable. If this option is missing, we'll default to using C. Note however, that going this route will not allow you to share your data across processes. The key can be specified as: =over 4 =item * A text string (internally, a 32-bit CRC of the string is used as the key) =item * A hex string (eg. C<'0xDEADBEEF'>), which we convert to integer form =item * A hex value (eg. C<0xDEADBEEF>), used as-is as the integer key =item * An integer (eg. C<1234>), used as-is as the integer key =back Default: B =head2 create B is used to control whether the process creates a new shared memory segment or not. If B is set to a true value, L will create a new binding associated with GLUE as needed. If B is false, L will not attempt to create a new shared memory segment associated with GLUE. In this case, a shared memory segment associated with GLUE must already exist or we'll C. Default: B =head2 exclusive If B field is set to a true value, we will C if the data binding associated with GLUE already exists. If set to a false value, calls to C will succeed even if a shared memory segment associated with GLUE already exists. See L for a silent, non-exception exit if a second process attempts to obtain an in-use C segment. Default: B =head2 graceful If B is set to a true value, we normally C if a second process attempts to obtain the same shared memory segment. Set B to true and we'll C silently and gracefully. This option does nothing if C isn't set. See L to emit a warning before gracefully exiting when a collision occurs. Default: B =head2 warn When set to a true value, B will output a warning if there are process collisions. Default: B =head2 mode The B argument is an octal number specifying the access permissions when a new data binding is being created. These access permission are the same as file access permissions in that C<0666> is world readable and writable, C<0600> is writable only by the effective UID of the process creating the shared variable, etc. Default: B<0666> (world readable and writeable) =head2 size This field is used to specify the size (in bytes) of each shared memory segment allocated. B: Each nested data structure requires a new shared memory segment. The C attribute is applied to the first, and all subsequent segments created, and does not reflect the overall size of memory to be used. The maximum size we allow for each segment by default is ~1GB. See the L option to override this default. Default: C (ie. B<65,536> bytes) =head2 protected The segments with this option set will persist even through all of our automatic and manual clean up procedures, less L. Set this to a non-zero integer. The integer is persisted in the segment's associated semaphore set, so any process that later attaches to the same segment via C<< create => 0 >> will automatically have this attribute restored; it does not need to pass C<< protected >> explicitly. The integer acts as a group key: all segments (including nested children) created under the same protected parent share the same value, so a single call to C removes the entire group. To clean up protected objects, call C<< (tied %object)->clean_up_protected(integer) >>, where 'integer' is the value you set the C option to. You can call this cleanup routine in the script you created the segment, or anywhere else, at any time. B: The protect key is limited to values accepted by the system's semaphore implementation (typically 0-32767; 0 means unprotected). Default: B<0> =head2 testing Set this to a non-empty string (conventionally the distribution name, e.g. C<'IPC::Shareable'>) to brand the segment as belonging to a particular test suite. At segment-creation time the CRC32 hash of the string is stored in a fifth semaphore slot (C). This makes it possible for L to find and remove every such segment system-wide -- including orphans from previous crashed runs -- without needing them to be in C<%global_register>. The integer hash (not the original string) is persisted in the semaphore set. When a process re-attaches to a segment that was created with C, the stored integer is restored into C<< attributes('testing') >>. Rather than setting C on every individual C, call L once at the top of the test file; all subsequent ties in that process (and in forked children spawned after the call) inherit it automatically. Default: B<0> (disabled) =head2 limit This field will allow you to set a segment size larger than the default maximum which is 1,073,741,824 bytes (approximately 1 GB). If set, we will C if a size specified is larger than the maximum. If it's set to a false value, we'll C if you send in a size larger than the total system RAM. Default: B =head2 destroy If set to a true value, the shared memory segment underlying the data binding will be removed when the process that initialized the shared memory segment exits cleanly. Only those memory segments that were created by the current process will be removed. Use this option with care. In particular you should not use this option in a program that will fork after binding the data. On the other hand, shared memory is a finite resource and should be released if it is not needed. B: If the segment was created with its L attribute set, it will not be removed upon program completion, even if C is set. Default: B =head2 serializer By default, we use L as the data serializer when writing to or reading from the shared memory segments we create. For cross-platform and cross-language interoperability this is the recommended choice. Alternatively, you can use L for richer data type support (eg. blessed objects). Send in either C or C as the value to use the respective serializer. Default: B =head2 enforced_write_locking When enabled, writes from any knot are blocked while another knot holds C on the segment, or while there are active C readers. Pair with C to also emit a warning when a write is blocked. B: This protection system will never be reached if all callers use proper locking at all times. Default: B =head2 violated_write_lock_warn When C is enabled, and this attribute is set to true, we will emit a warning when a write violation occurs (a write attempted against a segment that another knot has locked with C, or a write attempted against a segment with active C readers). The warning includes the UUID of the object that caused the violation and the segment ID it occurred against. Default: B =head2 enforced_read_locking When enabled, an unlocked read against a segment that another knot has locked with C is detected. Reads are never B; this option only controls whether the check fires. Pair with C to emit a warning when this happens. B: Reads (fetches) are never blocked, even when a C is active. If a reader does not hold a C and reads while a writer holds C, the returned data may be stale or partially-written. To guarantee a coherent snapshot, acquire C before reading. B: This protection system will never be reached if all callers use proper locking at all times. Default: B =head2 violated_read_lock_warn When C is enabled, and this attribute is set to true, we will emit a warning when an unlocked read is attempted against a segment that another knot has locked with C. The returned data may be stale or partially-written; the warning recommends acquiring C before reading to guarantee a coherent snapshot. The warning includes the UUID of the object that caused the violation and the segment ID it occurred against. Default: B =head2 Default Option Values Default values for options are: key => IPC_PRIVATE, # 0 create => 0, exclusive => 0, mode => 0666, size => IPC::Shareable::SHM_BUFSIZ(), # 65536 protected => 0, testing => 0, limit => 1, destroy => 0, graceful => 0, warn => 0, serializer => 'json', enforced_write_locking => 1, enforced_read_locking => 1, violated_write_lock_warn => 1, violated_read_lock_warn => 1, =head1 METHODS - STANDARD USER These are typically the only methods a normal user will need in the course of their use of this distribution. =head2 new This C call is not necessary and is a simple wrapper around C. It is capable only of returning a tied reference object (by default, a hash ref). Instantiates and returns a reference to a hash backed by shared memory. my $href = IPC::Shareable->new(key => "testing", create => 1); $href->{a} = 1; # Call tied() on the dereferenced variable to access object methods # and information tied(%$href)->seg_count; Parameters: Optional: See the L section for a list of all available options. Most often, you'll want to at minimum, send in the B and B options. It is possible to get a reference to an array or scalar as well. Simply send in either C<< var => 'ARRAY' >> or C<< var => 'SCALAR' >> to do so. Return: A reference to a hash (or array or scalar) which is backed by shared memory. =head2 lock($flags, $code) Obtains a lock on the shared memory. C<$flags> specifies the type of lock to acquire. If C<$flags> is not specified, an exclusive read/write lock is obtained. Acceptable flags are: LOCK_EX - Exclusive; use when writing LOCK_SH - Shared; use when reading LOCK_EX|LOCK_NB - Exclusive, non-blocking LOCK_SH|LOCK_NB - Shared, non-blocking Parameters: $flags Optional, Integer: If this parameter is omitted, we default to C, an exclusive write lock. $code Optional, Code reference: If this parameter is sent in, and an exclusive lock is asked for, we will set the lock, execute the subroutine, and then call C on the segment. The sub is called within an C, so we will C, then C with whatever error your function threw. B: Although the C<$flags> and C<$code> parameters appear positional, you can send in C<$code> without sending in any C<$flags>. When this occurs, C<$flags> will automatically be set to C. Return: C on success, and C on error. For non-blocking calls, the method returns C<0> if it would have blocked. Obtain an exclusive lock like this: tied(%var)->lock(LOCK_EX); # Same as default Only one process can hold an exclusive lock on the shared memory at a given time. Obtain a shared (read) lock: tied(%var)->lock(LOCK_SH); Multiple processes can hold a shared (read) lock at a given time. If a process attempts to obtain an exclusive lock while one or more processes hold shared locks, it will be blocked until they have all finished. Either of the locks may be specified as non-blocking: tied(%var)->lock( LOCK_EX|LOCK_NB ); tied(%var)->lock( LOCK_SH|LOCK_NB ); A non-blocking lock request will return C<0> immediately if it would have had to wait to obtain the lock. B: These locks are advisory (just like flock), meaning that all cooperating processes must coordinate their accesses to shared memory using these calls in order for locking to work. See the C call for details. B: You can enforce a C lock at a software level by ensuring that the C option is set to a true value (the default). This will prevent processes that decide not to implement the advisory locking from writing to the segment. The companion C option (also true by default) enables detection of unlocked reads against an exclusively-locked segment; reads are never blocked, but a warning will be emitted if C is also set. B: Locks are inherited through forks, which can cause unintended and problematic side effects (particularly duplicated C locks). Don't C until all active locks have been released. The constants C, C, C, and C are available for import using any of the following export tags: use IPC::Shareable qw(:lock); use IPC::Shareable qw(:flock); use IPC::Shareable qw(:all); Or, just use the C constants available in the C module. See L for further details. =head2 unlock Removes a lock. Takes no parameters, returns C on success. This is equivalent to calling C. See L for further details. =head2 singleton($glue, $warn) Class method that ensures that only a single instance of a script can be run at any given time. Parameters: $glue Mandatory, String: The key/glue that identifies the shared memory segment. $warn Optional, Bool: Send in a true value to have subsequent processes throw a warning that there's been a shared memory violation and that it will exit. Default: B Return: C<$$>. The process ID. B: See L. That library implements C for a script with a simple C line. =head1 METHODS - OBJECT AND PROCESS These methods provide facilities for identifying information about the current object and the overall state information of the current processes. =head2 attributes Retrieves the list of attributes that drive the L object. Attributes are the C that were used to create the object. Parameters: $attribute Optional, String: The name of the attribute. If sent in, we'll return the value of this specific attribute. Returns C if the attribute isn't found. Returns: A hash reference of all attributes if C<$attributes> isn't sent in, the value of the specific attribute if it is. =head2 global_register Returns a hash reference of hashes of all in-use shared memory segments across all processes/forks within the current process space. The key is the memory segment ID, and the value is the segment and semaphore objects. =head2 process_register Returns a hash reference of hashes of all in-use shared memory segments created by the calling process only (ie. not including forks). The key is the memory segment ID, and the value is the segment and semaphore objects. =head2 uuid Returns the UUID of the object. =head1 METHODS - MANUAL CLEANUP These methods are mainly for forced cleanup. C is used internally. These methods are generally never needed by a normal user, and are primarily for use in unit testing and other development work. =head2 clean_up IPC::Shareable->clean_up; # or tied($var)->clean_up; # or $knot->clean_up; This is a class method that provokes L to remove all shared memory segments created by the process. Segments not created by the calling process are not removed. This method will not clean up segments created with the C option. =head2 clean_up_all IPC::Shareable->clean_up_all; # or tied($var)->clean_up_all; # or $knot->clean_up_all This is a class method that provokes L to remove all shared memory segments encountered by the process. Segments are removed even if they were not created by the calling process. This method will not clean up segments created with the C option. =head2 clean_up_protected($protect_key) If a segment is created with the C option, it, nor its children will be removed during calls of C or C. When setting L, you specified a lock key integer. When calling this method, you must send that integer in as a parameter so we know which segments to clean up. Because the protect key is stored in the segment's semaphore set, any process that attached to the segment (even without passing C<< protected >> on tie) will have had its in-process attribute populated automatically. You can therefore call C from any process that has attached to the segment, not only from the one that created it. my $protect_key = 93432; IPC::Shareable->clean_up_protected($protect_key); # or tied($var)->clean_up_protected($protect_key); # or $knot->clean_up_protected($protect_key) Parameters: $protect_key Mandatory, Integer: The integer protect key you assigned with the C option =head2 remove($key) Parameters: $key Optional, see L for valid values. Preferably, an integer or a hex string prefixed with C<0x>. B: If the C<$key> parameter is sent in, we will delete that segment only and return immediately thereafter. tied($var)->remove; # or $knot->remove; # Remove a specific segment by key (can remove non C # segments). If key is sent in, the caller can be the module or the object. IPC::Shareable->remove('0xdeadbeef'); # hex string IPC::Shareable->remove(0xdeadbeef); # hex integer IPC::Shareable->remove(1234); # integer tied($var)->remove('Test'); # string B: Calling C on the object underlying a Cd variable removes the associated shared memory segment. The segment is removed irrespective of whether it has the B option set or not and irrespective of whether the calling process created the segment. =head1 METHODS - SYSTEM AND SHARED MEMORY These methods are for very low level diagnostic, troubleshooting, investigation, informational and fact finding situations. B: Both L and L are external objects and have their own methods and data that can be used for analysis. This is particularly true with L. Each of their respective documentation sections link to their corresponding documentation. =head2 seg Called on either a tied variable or on the tie object, returns the shared memory segment object currently in use. tie my %h, ...; $h{a}->{b}{c} = 10; my $top_level_seg = tied(%h)->seg; my $bot_level_seg = tied(%{ $h{a}->{b} })->seg; See L documentation for details and available methods. =head2 sem Called on either a tied variable or on the tie object, returns the semaphore object related to the memory segment currently in use. tie my %h, ...; $h{a}->{b}{c} = 10; my $top_level_sem = tied(%h)->sem; my $bot_level_sem = tied(%{ $h{a}->{b} })->sem; See L documentation. =head2 seg_count Returns the number of shared memory segments that currently exist on the system, by counting data lines in your system's C output. It is guaranteed to produce consistent results. Return: Integer =head2 sem_count Returns the number of semaphore sets that currently exist on the system, by parsing C. Since each L segment is associated with exactly one semaphore set (same SysV key), this count moves in lockstep with L when L segments are the only semaphore users on the system and are created and destroyed cleanly. Return: Integer =head2 shm_segments($key) my $ipc_shareable_segments = IPC::Shareable->shm_segments; # Filtered to one variable's segments only my $segs = IPC::Shareable->shm_segments('my_key'); my $segs = IPC::Shareable->shm_segments('0xDEADBEEF'); Class/object method. Scans all existing shared memory segments on the system and returns a hash reference mapping the hex key string (eg. C<'0xdeadbeef'>) to the raw literal contents of that segment. Only loads segments that were created by L. Segments created with C (key C<0x00000000>) are skipped because they cannot be looked up by key. Parameters: $key Optional, String or Int: If sent in, we will restrict the result to only the segments related to the variable the C<$key> reflects. Without this parameter, all L segments on the system are returned. Return: Hash reference where each key is the SHM key in hex format. Field descriptions: B: C<1> if this segment is currently tied in the calling process, C<0> if not. A value of C<0> includes segments legitimately persisted by another process (C 0>), not just crashed leftovers. See L for important caveats. B: C<1> if created by the same process this method is being run, and C<0> if not. B: The actual raw content of the shared memory segment. B: Nested data structures each require their own segment. Keys within this array reference map to child segments. Here's an example data structure, and what the return value of C would look like for it using the JSON serializer. Note that the top-level structure is a hash, and it contains two nested hashes (keys 'c' and 'd'), which are each stored in their own segments. It also has two scalar values (keys 'a' and 'b'), which are stored in the top-level segment. # Actual data { a => 1, b => 'hello', c => { x => 10, y => 20, }, d => { p => 'foo', q => 'bar', }, } # Call return (JSON content strings will be on one line; separated for # clarity) { '0x2abc0001' => { known => 1, local_process => 1, content => 'IPC::Shareable{ "a": 1, "b": "hello", "c": { "__ics__": { "child_key_hex": "0x000e1b1d", "child_key": "924445", "type": "HASH" } }, "d": { "__ics__": { "child_key_hex": "0x000097af", "child_key": "38831", "type": "HASH" } } }', child_keys => [ '0x000e1b1d', '0x000097af' ], }, '0x000e1b1d' => { known => 1, local_process => 1, content => 'IPC::Shareable{"y":20,"x":10}', child_keys => [], }, '0x000097af' => { known => 1, local_process => 1, content => 'IPC::Shareable{"p":"foo","q":"bar"}', child_keys => [], } } =head2 unknown_segments my @unknown_segments = IPC::Shareable->unknown_segments; for my $key (@unknown_segments) { print "Unknown segment: $key\n"; IPC::Shareable->remove($key); } Class/object method. Returns a list of hex key strings (eg. C<'0xdeadbeef'>) for all shared memory segments that were created by L but are not currently tied in the calling process. B: this method has no way to distinguish between a segment that was left behind by a crashed process and one that is legitimately persisted by another running process (C 0>). Both will appear in the returned list. Only call C on entries you are certain belong to your own application and are no longer in use. Return: List of hex key strings. =head2 seg_map # Show all IPC::Shareable segments visible on the system print IPC::Shareable->seg_map; # Show only the segment tree rooted at this object print $knot->seg_map; print tied(%hash)->seg_map; When called as a B, returns a human-readable string showing all L shared memory segments visible on the current system, organised as a tree (root segments at the top, nested children indented below their parent). When called as an B, the output is filtered to just the segment tree rooted at that object (the segment itself plus any nested children). For each segment the output includes: =over 4 =item * The hex key and OS segment ID =item * Status tags: C (tied in this process) or C, and C if this process created the segment =item * Semaphore information: OS semaphore ID (C), C, read-lock counter, write-lock counter, and C (the integer stored in C) =item * The list of child segment hex keys, or C<(none)> =item * The segment's current content. Reference values that are child segments are shown as C<< >> rather than being recursed into. Segments not tied in this process show C<(not accessible)>. =back Example: tie my %h, 'IPC::Shareable', { key => 0x1a2b, create => 1, destroy => 1 }; $h{nested} = { x => 1, y => 2 }; my $mapping = tied(%h)->seg_map; print $mapping; Output: IPC::Shareable Segment Map ========================== [known, owner] key: 0x00001a2b seg_id: 1890844693 Semaphores: sem_id: 1272774674 1: SEM_MARKER=1 2: READERS=0 3: WRITERS=0 4: PROTECTED=0 Children: 0x00018373 Content: { nested => } [known, owner] key: 0x00018373 seg_id: 1888682002 Semaphores: sem_id: 1300234259 1: SEM_MARKER=1 2: READERS=0 3: WRITERS=0 4: PROTECTED=0 Children: (none) Content: { x => "1", y => "2" } =head2 sysv_info my $sysv_info = IPC::Shareable->sysv_info; print "Max segment size: $sysv_info->{shmmax}\n"; print "Max segments (system): $sysv_info->{shmmni}\n"; print "Max semaphore sets (system): $sysv_info->{semmni}\n"; Class method. Returns a hash reference containing the kernel's SysV shared memory and semaphore configuration parameters for the current platform. Returns C if the platform is not supported or no data could be read. On MacOS, reads from C. Example return value: { shmmax => 4194304, # Maximum size of a single segment (bytes) shmmin => 1, # Minimum size of a single segment (bytes) shmmni => 32, # Maximum number of segments system-wide shmseg => 8, # Maximum number of segments per process shmall => 1024, # Maximum total shared memory (pages) semmni => 87381, # Maximum number of semaphore identifier sets semmns => 87381, # Maximum semaphores system-wide semmsl => 87381, # Maximum semaphores per set } On Linux, reads from C. Example return value: { shmmax => 18446744073692774399, # Maximum size of a single segment (bytes) shmmin => 1, # Minimum size of a single segment (bytes) shmmni => 4096, # Maximum number of segments system-wide shmall => 18446744073692774399, # Maximum total shared memory (pages) semmsl => 32000, # Maximum semaphores per set semmns => 1024000000, # Maximum semaphores system-wide semopm => 500, # Maximum semop ops per call semmni => 32000, # Maximum number of semaphore identifier sets } Note: Linux has no per-process segment limit (C); only the system-wide C applies. The four C keys come from C (one line: C). On FreeBSD, reads from C. Example return value: { shmmax => 536870912, # Maximum size of a single segment (bytes) shmmin => 1, # Minimum size of a single segment (bytes) shmmni => 192, # Maximum number of segments system-wide shmseg => 128, # Maximum number of segments per process shmall => 131072, # Maximum total shared memory (pages) semmni => 50, # Maximum number of semaphore identifier sets semmns => 340, # Maximum semaphores system-wide semmsl => 340, # Maximum semaphores per set semopm => 100, # Maximum semop ops per call } On OpenBSD, reads from C. Example return value: { shmmax => 33554432, # Maximum size of a single segment (bytes) shmmin => 1, # Minimum size of a single segment (bytes) shmmni => 128, # Maximum number of segments system-wide shmall => 8192, # Maximum total shared memory (pages) semmni => 10, # Maximum number of semaphore identifier sets semmns => 60, # Maximum semaphores system-wide semmsl => 60, # Maximum semaphores per set } On Solaris (including OmniOS/illumos), the kernel's SysV configuration is not yet read programmatically. This method returns C on Solaris; use system tools such as C or C to inspect the kernel IPC limits instead. C in particular is the limit that test suites making heavy use of shared-memory tied variables most often hit. FreeBSD's default of 50 is unusually tight; OpenBSD's default of 10 is tighter still. Test code that needs to scale by available capacity can compute C<< $info->{semmni} - IPC::Shareable::sem_count() >> as the headroom currently available for new allocations. Return: Hash reference, or C if the platform is not supported or no data could be read. =head1 METHODS - UNIT TESTING =head2 testing_set($dist_name) IPC::Shareable->testing_set('My::Distribution'); Sets a process-level tag so that every subsequent C in the same process automatically receives C<< testing => 'My::Distribution' >> without needing it on each individual tie. The tag propagates to nested-segment children (created automatically when a reference is stored into a tied variable) and to any processes forked B the call, because C copies the parent's memory. Call this once at the top of each test file (or from a shared helper module loaded with C). This flag can also be set with the L flag in the initial tie params. Parameters: $dist_name Mandatory, non-empty string: conventionally the distribution name. Croaks if C<$dist_name> is undefined or empty. =head2 clean_up_testing($dist_name) IPC::Shareable::clean_up_testing('My::Distribution'); # or as a method: IPC::Shareable->clean_up_testing('My::Distribution'); Performs a B scan for every IPC::Shareable segment whose C semaphore slot contains the CRC32 hash of C<$dist_name>, and removes each matching segment and its semaphore set -- B one that another, still-running process owns. A matching segment is removed when it was created by the calling process, or when its creator process has since exited (ie. an orphan left by a crashed run). A segment whose creator is still alive in some other process is left untouched. This makes the call safe to use even while the same distribution's test suite is running concurrently -- under C, or by several smokers at once -- where it would otherwise tear down segments those sibling processes are still using. Unlike L, this function is not limited to segments in C<%global_register>: it will find and remove orphaned segments from previous crashed test runs. Unlike L, it deliberately ignores the C attribute -- a matching segment tagged with C is removed regardless. A second pass reclaims B -- ones whose shared memory segment is already gone, eg. when a crashed run died between removing a segment and removing its semaphore set. Such a set can never be re-attached (the segment is always created before its semaphore set), yet it pins one of the system's C slots forever; on hosts with a tiny limit (OpenBSD defaults to C) the accumulation eventually starves every subsequent C into C. Only sets carrying the matching C marker are touched. The typical usage is at the top of the first test file (before any segments are created) to clear orphans, and optionally at the end of the last test file as a belt-and-suspenders cleanup: # t/00-base.t # First, clean up from the previous run if necessary my $n = IPC::Shareable::clean_up_testing('My::Distribution'); note "Removed $n orphaned segments from previous run" if $n; # Now set tagging for segments in this test file IPC::Shareable->testing_set('My::Distribution'); Parameters: $dist_name Mandatory, non-empty string: the same string passed to L or the C tie attribute. Return: integer count of removed segments. B: C on a re-attached segment returns the stored integer hash, not the original string. This is intentional: the hash is sufficient for cleanup comparisons and the original string is never stored on the system. =head1 LOCKING IPC::Shareable provides methods to implement application-level advisory and enforced locking of the shared data structures. These methods are C and C. To use them you must first get the object underlying the tied variable, either by saving the return value of the original call to C or by using the built-in C function. See L for flag combinations allowed. =head2 Lock and unlock To lock and subsequently unlock a variable, do this: tie my %hash, 'IPC::Shareable', { %options }; tied(%hash)->lock; $hash{a}->{b} = 1; tied(%hash)->unlock; This will place an exclusive lock on the data of C<%hash>, including all nested data below the parent. You can also get shared locks or attempt to get a lock without blocking. L makes the constants C, C, C, and C exportable to your address space with the export tags C<:lock>, C<:flock>, or C<:all>. The values should be the same as the standard C option arguments. When attempting to get a blocking lock (eg. C or C) while another process has an exclusive write lock (C), your call will block and wait until the other process releases its exclusive lock. The same thing happens if you attempt to get a C if there are any other processes that hold a C. Here is an example of how to manage a non-blocking lock: if (tied(%hash)->lock(LOCK_SH|LOCK_NB)) { print "The value is $hash{a}\n"; tied(%hash)->unlock; } else { print "Another process has an exclusive lock.\n"; } If no argument is provided to C, it defaults to C. =head2 Enforced write and read locking Additional safeguards are in place to protect your locked data from processes that don't bother to implement locking explicitly. =head3 Violating an enforced write lock By default, the C option is set to true, which means that if a tied variable sets a C, all writes from all other processes will fail, and their data will not be updated. If the offending process has C set to true (also default), it will receive a warning regarding the issue. =head3 Violating an enforced read lock Also enabled by default, the C will catch instances where a process attempts a read of data that is currently locked with C by another process. Unlike write protection, read protection does not prevent the read; it simply sets the stage for you to be able to warn the user that they are receiving stale data. To have the user warned that they are in fault, the C option must be set to true, which it is by default. The warning advises the user that the data they have received is stale, and that they should refactor their code to implement proper locking. =head2 Important notes Note that in the background, we perform lock optimization when reading and writing to the shared storage even if the advisory locks aren't being used. Using the advisory locks can speed up processes that are doing several writes/ reads at the same time (ie. transactions). When using C to lock a variable, be careful to guard against signals. Under normal circumstances, C's C method unlocks any locked variables when the process exits. However, if an untrapped signal is received while a process holds a lock, C will not be called. This is I a deadlock risk: all semaphore lock operations in C use the C flag, which causes the kernel to automatically reverse any semaphore operations when the process exits, regardless of the cause of death (including C and hardware faults). Other processes waiting for the lock will be unblocked. =head1 LOCKING BEHAVIOR MATRIX The following matrix describes what happens to a second object (B) when a first object (A) holds C on a segment, across all combinations of the four lock-control attributes: =over 4 =item * EW = C =item * ER = C =item * WW = C =item * WR = C =back =head2 Lock acquisition (attribute-independent) C runs at the kernel level; none of the four flags affect whether a lock is granted. +--------------------------+----------------------------------------------+ | B's attempt | Lock result while A holds LOCK_EX | +--------------------------+----------------------------------------------+ | LOCK_EX | Blocks, then acquires once A unlocks | | LOCK_EX | LOCK_NB | Returns 0 immediately | | LOCK_SH | Blocks, then acquires once A unlocks | | LOCK_SH | LOCK_NB | Returns 0 immediately | | (no lock) | N/A | +--------------------------+----------------------------------------------+ =head2 Behavior after lock state is established =head3 Case 1: B successfully holds LOCK_EX (blocking attempts complete after A unlocks) All flags are irrelevant; C uses the cache (skipping the read check), and the write check bypasses on C ownership. +----------+--------------+-----------+--------------+ | Read | Read warn? | Write | Write warn? | +----------+--------------+-----------+--------------+ | cache | never | succeeds | never | +----------+--------------+-----------+--------------+ =head3 Case 2: B successfully holds LOCK_SH (after A unlocks) C uses cache (no read warn possible). Writes go through the write check, which sees C 0> from B's own C. +----+----+------------------------------------+--------------+ | EW | WW | Write outcome | Write warn? | +----+----+------------------------------------+--------------+ | 0 | * | succeeds (enforcement off) | no | | 1 | 0 | blocked ("active readers") | no | | 1 | 1 | blocked ("active readers") | YES | +----+----+------------------------------------+--------------+ =head3 Case 3: B is unlocked (NB attempt returned 0, or B never attempted a lock); A still holds LOCK_EX, so SEM_WRITERS = 1 +----+----+----+----+-------------------+--------------+-------------------+---------------+ | EW | ER | WW | WR | Read | Read warn? | Write | Write warn? | +----+----+----+----+-------------------+--------------+-------------------+---------------+ | 0 | 0 | 0 | 0 | raw shmem (stale) | no | succeeds (race) | no | | 0 | 0 | 0 | 1 | raw shmem | no | succeeds | no | | 0 | 0 | 1 | 0 | raw shmem | no | succeeds | no | | 0 | 0 | 1 | 1 | raw shmem | no | succeeds | no | | 0 | 1 | 0 | 0 | raw shmem | no | succeeds | no | | 0 | 1 | 0 | 1 | raw shmem | YES | succeeds | no | | 0 | 1 | 1 | 0 | raw shmem | no | succeeds | no | | 0 | 1 | 1 | 1 | raw shmem | YES | succeeds | no | | 1 | 0 | 0 | 0 | raw shmem | no | blocked | no | | 1 | 0 | 0 | 1 | raw shmem | no | blocked | no | | 1 | 0 | 1 | 0 | raw shmem | no | blocked | YES | | 1 | 0 | 1 | 1 | raw shmem | no | blocked | YES | | 1 | 1 | 0 | 0 | raw shmem | no | blocked | no | | 1 | 1 | 0 | 1 | raw shmem | YES | blocked | no | | 1 | 1 | 1 | 0 | raw shmem | no | blocked | YES | | 1 | 1 | 1 | 1 | raw shmem | YES | blocked | YES | +----+----+----+----+-------------------+--------------+-------------------+---------------+ =head2 When A holds LOCK_SH instead of LOCK_EX When A holds a shared lock, C 0> and C. This collapses the matrix in three significant ways: =over 4 =item * B B's C and C both succeed immediately; multiple readers can hold C concurrently. Only the C attempts still block (or return 0 for the NB variant). +--------------------------+----------------------------------------------+ | B's attempt | Lock result while A holds LOCK_SH | +--------------------------+----------------------------------------------+ | LOCK_EX | Blocks, then acquires once A unlocks | | LOCK_EX | LOCK_NB | Returns 0 immediately | | LOCK_SH | Acquires immediately (concurrent readers OK) | | LOCK_SH | LOCK_NB | Acquires immediately | | (no lock) | N/A | +--------------------------+----------------------------------------------+ =item * B The read check tests C 0>, which is false. ER and WR become irrelevant; unlocked reads return raw shmem but never warn. The data is also genuinely fresher: A is reading, not writing, so there is no stale-write risk. =item * B Unlocked writes are still blocked when C, but via the C 0> branch of the write check. The warning text becomes: "...has active readers (enforced write locking enabled)" rather than the "exclusively locked" variant. Write outcome and warn behavior across (EW, WW) are otherwise identical to Case 3 above. =back =head2 Rules distilled from the matrix =over 4 =item * B is governed only by SysV semaphores; the four flags do not participate. =item * B is always raw shmem when unlocked, always cached when locked; the four flags only affect whether a warning is emitted, never the value returned. =item * B if C AND C AND another process holds C. =item * B if C AND (another process holds C OR has active C readers OR the caller itself holds only C). =item * B iff the write was blocked AND C. =item * C ownership bypasses every check in the write path and never reaches the read check, so the four flags never fire for the lock holder. =back =head1 DATA AND SEGMENT MAPPING For simple data (none of the values are references), a single segment is used throughout. However, with nested data, each value that is a reference is stored in its own, separate shared memory segment (the key is auto-generated). Consider a three-level hash: $h{a}{b}{c} = 1; This creates three segments: Root segment (SysV key 0xABCD) stored data: { a => } | v Child segment (SysV key 11111) stored data: { b => } | v Grandchild segment (SysV key 22222) stored data: { c => 1 } Each segment only knows about its direct children. The chain is followed lazily, one level at a time, as you C down into the structure. (See the L documentation to gather this structure within code). When you replace a child with a new reference where the previous value was also a reference, a new segment is created and the new data is stored there. The old segment is automatically removed. When a value that is a reference is deleted from the data, the memory segment that held that data is automatically cleaned up and freed. =head2 Storable With the Storable serializer, nested references are handled transparently. Storable natively freezes the entire Perl data structure (including internal tie information for child segments) into a single binary blob. On thaw, child segments are automatically re-attached without any explicit markers in the serialized data. This means that unlike JSON, there are no C<__ics__> placeholder objects in the stored data. The trade-off is that Storable output is Perl-specific and not portable across different Perl versions or platforms. See the C option under L to choose between C and C. =head2 JSON JSON can't serialize blessed objects, so each child pointer is written as an explicit marker: { "__ics__" => { type => "HASH", child_key => 11111, child_key_hex => "0x00002b67" } } The raw JSON in the root segment looks like: {"a":{"__ics__":{"type":"HASH","child_key":11111,"child_key_hex":"0x00002b67"}}} The raw JSON in the child segment (key 11111) looks like: {"b":{"__ics__":{"type":"HASH","child_key":22222,"child_key_hex":"0x000056ce"}}} Finally, the value in the child is not a reference, so it's stored as literal data: {"c": 1} On decode, any C<__ics__> marker is spotted and a tie with C 0> is used to re-attach to the existing child segment by that key; no new segment is created, it simply reconnects. =head1 SEMAPHORES Each memory segment that we utilize comes with it a semaphore set of four or five individual semaphores. These semaphores keep state information about the segment itself, and manages the locking aspects. A fifth slot (C) is added only when the segment is created with the L attribute. =head2 SEM_MARKER Semaphore slot ID 0. Signals whether the associated shared memory segment has been initialized and is ready for use. C<1> if it is, C<0> if it isn't. =head2 SEM_READERS Semaphore slot ID 1. Specifies the current number of readers holding a C. A write lock (C) can't be obtained until this value is reduced to C<0>. =head2 SEM_WRITERS Semaphore slot ID 2. Value is C<1> if a process has a C write lock, and C<0> if not. =head2 SEM_PROTECTED Semaphore slot ID 3. Used to keep track of the C option value for protected segments. See L. =head2 SEM_TESTING Semaphore slot ID 4. Present only on segments created with the L attribute. Stores the CRC32 hash of the distribution name (masked to a positive 31-bit integer) so that L can identify and remove all matching segments system-wide. Zero on segments that were not created with C. =head1 DESTRUCTION perl will destroy the object underlying a tied variable when the tied variable goes out of scope. Unfortunately for L, this may not be desirable: other processes may still need a handle on the relevant shared memory segment. L therefore provides several options to control the timing of removal of shared memory segments. B: The destruction is handled in an C block. Only those memory segments that are tied to the current process will be removed. =head2 destroy Option As described in L, specifying the B option when Cing a variable coerces L to remove the underlying shared memory segment when the process calling C exits gracefully. =head2 Signal handlers The C block only runs on a I exit (normal program end, C, or C). It does B run for untrapped signals (C, C, etc.) or for C. If your process may be terminated by a signal and you want C cleanup to run, install signal handlers that call C: $SIG{INT} = $SIG{TERM} = $SIG{HUP} = sub { exit }; This causes the C block to fire on those signals. C cannot be caught; any segments left behind by it can be recovered with Cclean_up_all>. =head2 Notes B: If the segment was created with its L attribute set, it will not be removed in the C block, even if C is set. B: Advisory locks (C/C) are I released automatically when a process dies, even on C, because the underlying semaphore operations use C. Lock release is therefore not a concern; only shared memory I data requires the signal handler precaution above. =head2 See also See L for further information. =head1 EXPORTS We do not export anything by default. You must request an item individually, or by tag. =head2 Tags =head3 :lock Aliases: C<:flock> Includes: C, C, C and C. =head3 :flock Simple legacy alias for C<:lock>. =head3 :semaphores Includes: C, C, C, C and C. =head3 :all Includes L and L. =head1 AUTHORS Benjamin Sugars Steve Bertrand (since 2016) =head1 NOTES =head2 Important Notes =over 4 =item o In v1.14, we changed our default serializer from C to C. For backward compatibility, there is a process whereby if you have existing segments saved in C format and the JSON serializer can't process it, we'll automatically fall back to C for you. You should however recreate the segments with the C serializer. =back =head2 General Notes =over 4 =item o This distribution has minor parts of it developed in C/XS, but these components are only built if we can determine that you've got the proper build tools installed. If not, we simply skip the XS build and fall back to our pure Perl code. =item o Iterating over a hash causes a special optimization if you have not obtained a lock (it is better to obtain a read (or write) lock before iterating over a hash tied to L, but we attempt this optimization if you do not). =item o For tied hashes, the C/C operation is performed when the first key is accessed. Subsequent key and value accesses are done without accessing shared memory. Doing an assignment to the hash or fetching another value between key accesses causes the hash to be replaced from shared memory. The state of the iterator in this case is not defined by the Perl documentation. Caveat Emptor. =back =head1 CREDITS Thanks to all those with comments or bug fixes, especially Maurice Aubrey Stephane Bortzmeyer Doug MacEachern Robert Emmery Mohammed J. Kabir Terry Ewing Tim Fries Joe Thomas Paul Makepeace Raphael Manfredi Lee Lindley Dave Rolsky Steve Bertrand =head1 SEE ALSO L, L, C, C, C and other SysV IPC manual pages. =cut IPC-Shareable-1.19/lib/IPC/Shareable/000755 000765 000024 00000000000 15222770207 017307 5ustar00stevestaff000000 000000 IPC-Shareable-1.19/lib/IPC/Shareable/SharedMem.pm000644 000765 000024 00000037733 15211731422 021521 0ustar00stevestaff000000 000000 package IPC::Shareable::SharedMem; use warnings; use strict; use Carp qw(carp croak confess); use Config; use Errno qw(EEXIST EPERM); use IPC::SysV qw(IPC_RMID IPC_STAT); our $VERSION = '1.19'; use constant { DEFAULT_SEG_SIZE => 1024, DEFAULT_SEG_FLAGS => 0000, DEFAULT_SEG_MODE => 0666, }; { package IPC::Shareable::SharedMem::stat; use Class::Struct qw(struct); struct 'IPC::Shareable::SharedMem::stat' => [ uid => '$', gid => '$', cuid => '$', cgid => '$', mode => '$', segsz => '$', lpid => '$', cpid => '$', nattch => '$', atime => '$', dtime => '$', ctime => '$', ]; } sub new { my ($class, %params) = @_; my $self = bless {}, $class; if (defined $params{key} && $params{key} =~ /^0x[0-9a-fA-F]+$/i) { $params{key} = hex($params{key}); } if (! defined $params{key} || $params{key} !~ /^\d+$/) { croak "new() requires a 'key' parameter with an integer value"; } $self->key($params{key}); $self->key_hex($self->key); $self->size($params{size} || DEFAULT_SEG_SIZE); $self->mode($params{mode} || DEFAULT_SEG_MODE); $self->flags(($params{flags} || DEFAULT_SEG_FLAGS) | $self->mode); $self->type($params{type}); my $id = shmget($self->key, $self->size, $self->flags); defined $id or do { my $key = $self->key_hex; if ($!) { if ($!{EEXIST} || $!{EPERM}) { croak "\nERROR: IPC::Shareable::SharedMem: shmget $key: $!\n\n" . "Are you using exclusive, but trying to create multiple " . "instances?\n\n"; } return undef; } }; $self->id($id); return $self; } sub id { my ($self, $id) = @_; if (defined $id) { if ($self->{id}) { warn "Can't set id() after object already instantiated"; return $self->{id}; } $self->{id} = $id; } return $self->{id}; } sub key { my ($self, $key) = @_; if (defined $key) { if ($self->id) { croak "Can't set the 'key' attribute after object is already established"; } $self->{key} = $key; } return $self->{key}; } sub key_hex { my ($self, $key_int) = @_; if (defined $key_int) { $self->{key_hex} = sprintf "0x%08x", $key_int; } return $self->{key_hex}; } sub flags { my ($self, $flags) = @_; if (defined $flags) { if ($self->id) { warn "Can't set flags() after object already instantiated"; return $self->{flags}; } $self->{flags} = $flags; } return $self->{flags}; } sub mode { my ($self, $mode) = @_; if (defined $mode) { if ($self->id) { warn "Can't set mode() after object already instantiated"; return $self->{mode}; } $self->{mode} = $mode; } return $self->{mode}; } sub size { my ($self, $size) = @_; if (defined $size) { if ($self->id) { warn "Can't set size() after object already instantiated"; return $self->{size}; } if ($size !~ /^\d+$/) { croak "size() requires an integer as parameter"; } $self->{size} = $size; } return $self->{size}; } sub type { my ($self, $type) = @_; if (defined $type) { if ($self->id) { warn "Can't set type() after object already instantiated"; return $self->{type}; } $self->{type} = $type; } return $self->{type}; } sub data { my ($self) = @_; my $data = $self->shmread; return if ! defined $data; my $pos = index($data, "\x00"); $data = $pos >= 0 ? substr($data, 0, $pos) : $data; return $data; } sub stat { my ($self) = @_; my $data = ''; shmctl($self->id, IPC_STAT, $data) or return undef; my %values; if ($^O eq 'linux') { if ($Config{longsize} == 8) { # 64-bit Linux: ipc64_perm is 48 bytes. # ipc64_perm: key(4) uid(4) gid(4) cuid(4) cgid(4) mode(4) # seq(2) pad2(2) [4-byte align-pad] unused1(8) unused2(8) # shmid_ds: segsz(8) atime(8) dtime(8) ctime(8) cpid(4) lpid(4) nattch(8) @values{qw(uid gid cuid cgid mode segsz atime dtime ctime cpid lpid nattch)} = unpack('x[4] L L L L L x[24] Q q q q l l Q', $data); } else { # 32-bit Linux: ipc64_perm is 36 bytes (unsigned long = 4 bytes). # ipc64_perm: key(4) uid(4) gid(4) cuid(4) cgid(4) mode(4) # seq(2) pad2(2) unused1(4) unused2(4) # shmid_ds: segsz(4) atime(4) atime_nsec(4) dtime(4) dtime_nsec(4) # ctime(4) ctime_nsec(4) cpid(4) lpid(4) nattch(4) @values{qw(uid gid cuid cgid mode segsz atime dtime ctime cpid lpid nattch)} = unpack('x[4] L L L L L x[12] L L x[4] L x[4] L x[4] l l L', $data); } } elsif ($^O eq 'freebsd' && $Config{longsize} == 8) { # 64-bit FreeBSD: ipc_perm is 32 bytes. # ipc_perm: cuid(4) cgid(4) uid(4) gid(4) mode(2) _seq(2) pad(4) _key(8) # shmid_ds: segsz(8) lpid(4) cpid(4) nattch(8) atime(8) dtime(8) ctime(8) # (key_t = long = 8 bytes on FreeBSD 64-bit, with 4 bytes of alignment padding) @values{qw(cuid cgid uid gid mode segsz lpid cpid nattch atime dtime ctime)} = unpack('L L L L S x[14] Q l l Q q q q', $data); } elsif ($^O eq 'solaris') { if ($Config{longsize} == 8) { # 64-bit Solaris/illumos _LP64 shmid_ds (136 bytes on OmniOS r151058): # ipc_perm (28 bytes): uid(4) gid(4) cuid(4) cgid(4) mode(4) seq(4) key(4) # [pad 4] segsz(8) [gap 8] lkcnt(2) [pad 2] lpid(4) cpid(4) # [pad 4] nattch(8) cnattch(8) atime(8) dtime(8) ctime(8) # shmatt_t = 8 bytes mode_t = uint_t = 4 bytes # Offsets verified on OmniOS r151058 via offsetof(). @values{qw(uid gid cuid cgid mode segsz lpid cpid nattch atime dtime ctime)} = unpack('L L L L L x[12] Q x[12] l l x[4] Q x[8] q q q', $data); } else { # 32-bit Solaris/illumos shmid_ds (108 bytes): # ipc_perm (44 bytes): uid(4) gid(4) cuid(4) cgid(4) mode(4) seq(4) key(4) pad[4](16) # segsz(4) lpid(4) cpid(4) lkcnt(2) [pad 2] nattch(4) cnattch(4) # atime(4) pad1(4) dtime(4) pad2(4) ctime(4) pad3(4) pad4[4](16) # mode_t = uint_t = 4 bytes @values{qw(uid gid cuid cgid mode segsz lpid cpid nattch atime dtime ctime)} = unpack('L4 L x[24] L l l x[4] L x[4] l x[4] l x[4] l x[20]', $data); } } elsif ($^O eq 'openbsd' && $Config{longsize} == 8) { # 64-bit OpenBSD shmid_ds (104 bytes), struct layout from sys/shm.h: # ipc_perm (32 bytes): uid(4) gid(4) cuid(4) cgid(4) mode(4/int) # +12 bytes (key/seq/pad) # segsz(4/int) lpid(4/pid_t) cpid(4/pid_t) nattch(2/shmatt_t) [pad 2] # atime(8/time_t) __shm_atimensec(8/long) # dtime(8/time_t) __shm_dtimensec(8/long) # ctime(8/time_t) __shm_ctimensec(8/long) # shm_internal(8/ptr) @values{qw(uid gid cuid cgid mode segsz lpid cpid nattch atime dtime ctime)} = unpack('L L L L L x[12] L l l S x[2] q x[8] q x[8] q', $data); } elsif ($^O eq 'dragonfly' && $Config{longsize} == 8) { # 64-bit DragonFly BSD shmid_ds (sys/sys/shm.h, sys/sys/ipc.h). # ipc_perm (28 bytes): # uid(4) gid(4) cuid(4) cgid(4) mode(4) _seq(2) [2 pad] _key(4) # [4 pad to align segsz] # shmid_ds: # segsz(8) lpid(4) cpid(4) nattch(8) # atime(8) [atimensec(8)?] dtime(8) [dtimensec(8)?] ctime(8) # # Some DragonFly versions include __shm_*timensec fields (108 bytes # total), others omit them (88 bytes). Detect via data length. if (length($data) > 96) { @values{qw(uid gid cuid cgid mode segsz lpid cpid nattch atime dtime ctime)} = unpack('L L L L L x[12] Q l l Q q x[8] q x[8] q', $data); } else { @values{qw(uid gid cuid cgid mode segsz lpid cpid nattch atime dtime ctime)} = unpack('L L L L L x[12] Q l l Q q q q', $data); } } else { # macOS shmid_ds / ipc_perm layout (XNU kernel): # # ipc_perm (24 bytes): uid(4) gid(4) cuid(4) cgid(4) mode(2/ushort) seq(2) key(4) # shmid_ds: segsz(8) lpid(4) cpid(4) nattch(2/ushort) [pad 2] atime(8) dtime(8) ctime(8) # # Fields happen to match stat_list() order, so a linear unpack works. @values{stat_list()} = unpack('L L L L S x[6] Q l l S x[2] q q q', $data); } my @struct_initializers; for (stat_list()) { my $value = $values{$_}; if ($_ eq 'mode') { $value = $value & 0777; push @struct_initializers, $_ => sprintf("%#o", $value); } else { push @struct_initializers, $_ => $value; } } return IPC::Shareable::SharedMem::stat->new(@struct_initializers); } sub stats { my ($self) = @_; my @stat_list = stat_list(); my $stat = $self->stat; my %stats; for (@stat_list) { $stats{$_} = $stat->$_; } return \%stats; } sub stat_list { return qw( uid gid cuid cgid mode segsz lpid cpid nattch atime dtime ctime ); } sub shmread { my ($self) = @_; my $data = ''; shmread($self->id, $data, 0, $self->size) or return; return $data; } sub shmwrite { my($self, $data) = @_; return shmwrite($self->id, $data, 0, $self->size); } sub remove { my ($self) = @_; my $os_return_value = shmctl($self->id, IPC_RMID, 0); if (defined $os_return_value && ($os_return_value eq '0 but true' || $os_return_value == 1)) { return 1; } else { return 0; } } 1; =head1 NAME IPC::Shareable::SharedMem - Allows access to a shared memory segment via an object oriented interface. =head1 DESCRIPTION This module provides object oriented access to a shared memory segment. Although it can be used standalone, it was designed for use specifically within the L<< IPC::Shareable >> library. =for html Coverage Status =head1 SYNOPSIS use IPC::Shareable::SharedMem; my $seg = IPC::Shareable::SharedMem->new( key => 1234, size => 65536, ); $seg->shmwrite($data); my $data = $seg->data; =head1 METHODS =head2 new(%params) Instantiates and returns an object that represents a shared memory segment. If for any reason we can't create the shared memory segment, we'll return C. Parameters (must be in key => value pairs): =head3 key I<< Mandatory, Integer >>: An integer that references the shared memory segment. =head3 size I: An integer representing the size in bytes of the shared memory segment. The maximum is Operating System independent. I: 1024 =head3 flags I: A bitwise mask of options logically OR'd together with any or all of C (create segment if it doesn't exist), C (exclusive access; if the segment already exists, we'll C) and C (create a read only segment). See L for further details. I: C<0> (ie. no flags). =head3 mode I: An octal number representing the access permissions for the shared memory segment. Exactly the same as a Unix file system permissions. I: 0666 (User RW, Group RW, World RW). =head3 type I: The type of data that will be stored in the shared memory segment. L uses C, C or C. =head2 id Sets/gets the identification number that references the shared memory segment. A warning will be thrown if you try to set the ID after the object is already instantiated, and no change will occur. =head2 key Sets/gets the key used to identify the shared memory segment. Setting this attribute should only be done internally. If it is sent in after the object is already associated with a shared memory segment, we will C. See L for further details. =head2 key_hex($key) Returns the hex formatted key which appears in C calls. Parameters: =head3 $key I<< Optional, String >>: This is always sent in during initialization. =head2 size Sets/gets the size of the shared memory segment in bytes. See L for further details. A warning will be thrown if you try to set the size after the object is already instantiated, and no change will occur. =head2 flags Sets/gets the flags that the segment will be created with. See L for details. A warning will be thrown if you try to set the flags after the object is already instantiated, and no change will occur. =head2 mode Sets/gets the access permissions. See L for further details. A warning will be thrown if you try to set the mode after the object is already instantiated, and no change will occur. =head2 type Sets/gets the type of data that will be contained in the shared memory segment. See L for details. A warning will be thrown if you try to set the type after the object is already instantiated, and no change will occur. =head2 data Returns the data in the shared memory segment, with all NULL pad bytes removed. Use this method for text data. For binary data where you need all blocks within the segment, use the L method. =head2 stat This method has sub methods that display various system-level information about the memory segment. These sub methods are: uid gid cuid cgid mode segsz lpid cpid nattch atime dtime ctime Example call: my $ctime = $seg->stat->ctime; =head2 stats Returns an href of the various system-level stat information: { uid => 501, gid => 20, cuid => 501, cgid => 20, mode => 0666, segsz => 65536, lpid => 61270, cpid => 61270, nattch => 0, atime => 1778791348, dtime => 1778791348, ctime => 1778791348, } =head2 stat_list Returns an array of all the segment's system stat entries. These are what make up the method names of the C<< $seg->stat >> object. =head2 shmread Returns the data (and NULL pad bytes) stored in the shared memory segment. By default, when data is retrieved from the shared memory segment, the data is padded to the right by NULL bytes to fill up the entire size of the segment. This can cause issues when using the space for non serialized data (ie. if you stored "hello" in a 1024 byte segment, the ASCII text wouldn't match). Typically this method is used when you want all blocks of the segment, such as if you've stored binary data. For text/ASCII data, use the L method which automatically strips NULL pad bytes. I: The data if any is stored, empty string if no data has been stored yet, and C if a failure to read occurs. =head2 shmwrite($data) Stores the serialized data to the shared memory segment. Parameters: $data I: Typically, the a serialized data structure. I: True on success, false on failure. =head2 remove Removes the shared memory segment and returns the resources to the system. I: True (C<1>) on success, false (C<0>) on failure. =head1 AUTHOR Ben Sugars (bsugars@canoe.ca) =head1 MAINTAINED BY Steve Bertrand =head1 SEE ALSO L, L, L =cut IPC-Shareable-1.19/t/81-sem-removed-under-lock.t000644 000765 000024 00000004745 15211723160 021406 0ustar00stevestaff000000 000000 use warnings; use strict; use Errno qw(EINVAL); use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use IPC::Semaphore; use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue); # Regression: when another process removes a segment's semaphore set, this # process's subsequent semaphore calls fail with EINVAL -- getval() returns # undef and op() returns false. The module must degrade gracefully rather than # emit 'uninitialized value' warnings (the CPAN-tester symptom) or croak. This # covers _write_permitted() and unlock(). The failing semaphore is simulated # with a localized override of IPC::Semaphore, so the real IPC resources still # clean up normally afterwards. # --- _write_permitted() tolerates getval() returning undef ---------------- { my $knot = tie my %h, 'IPC::Shareable', unique_glue('semgone_w'), { create => 1, destroy => 1, serializer => 'storable', }; my @warnings; my $permitted; { no warnings 'redefine'; local *IPC::Semaphore::getval = sub { return undef }; local $SIG{__WARN__} = sub { push @warnings, $_[0] }; $permitted = IPC::Shareable::_write_permitted($knot); } is $permitted, 1, "_write_permitted() permits the write when getval() returns undef"; is scalar(grep { /uninitialized value/i } @warnings), 0, "_write_permitted() emits no 'uninitialized value' warning on a removed set" or diag "got warnings: @warnings"; IPC::Shareable->clean_up_all; } # --- unlock() warns once, non-fatally, when op() fails with EINVAL --------- { my $knot = tie my %h, 'IPC::Shareable', unique_glue('semgone_u'), { create => 1, destroy => 1, serializer => 'storable', }; $knot->shlock; # hold a lock so unlock() issues a release semop my @warnings; my $survived; { no warnings 'redefine'; local *IPC::Semaphore::op = sub { $! = EINVAL; return 0 }; local $SIG{__WARN__} = sub { push @warnings, $_[0] }; $survived = eval { $knot->shunlock; 1 }; } is $survived, 1, "shunlock() does not die when the semaphore set is gone"; is scalar(grep { /removed by another process/i } @warnings), 1, "shunlock() warns (once) that the set was removed by another process" or diag "got warnings: @warnings"; IPC::Shareable->clean_up_all; } IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/22-lock_semaphore.t000644 000765 000024 00000003141 15207655146 020112 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use IPC::Shareable qw(:lock); IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue); my $t = tie my $sv, 'IPC::Shareable', { create => 1, key => unique_glue('data'), destroy => 1, serializer => 'storable', }; my @none = qw(1 0 0); my @excl = qw(1 0 1); my @exnb = qw(1 0 1); my @shar = qw(1 1 0); my @shnb = qw(1 1 0); for (0..2){ is $t->sem->getval($_), $none[$_], "before excl lock, sem $_ set to $none[$_] ok"; } $t->lock; for (0..2){ is $t->sem->getval($_), $excl[$_], "after excl lock, sem $_ set to $excl[$_] ok"; } $t->unlock; for (0..2){ is $t->sem->getval($_), $none[$_], "after excl lock unlock, sem $_ set to $none[$_] ok"; } $t->lock(LOCK_SH); for (0..2){ is $t->sem->getval($_), $shar[$_], "after shared lock, sem $_ set to $shar[$_] ok"; } $t->unlock; for (0..2){ is $t->sem->getval($_), $none[$_], "after shared lock unlock, sem $_ set to $none[$_] ok"; } $t->lock(LOCK_EX|LOCK_NB); for (0..2){ is $t->sem->getval($_), $exnb[$_], "after excl nb lock, sem $_ set to $exnb[$_] ok"; } $t->unlock; for (0..2){ is $t->sem->getval($_), $none[$_], "after excl nb lock unlock, sem $_ set to $none[$_] ok"; } $t->lock(LOCK_SH|LOCK_NB); for (0..2){ is $t->sem->getval($_), $shnb[$_], "after shared nb lock, sem $_ set to $shnb[$_] ok"; } $t->unlock; for (0..2){ is $t->sem->getval($_), $none[$_], "after share nb lock unlock, sem $_ set to $none[$_] ok"; } IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/02-create.t000644 000765 000024 00000001040 15207655146 016354 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue); my $ok = eval { tie my $sv, 'IPC::Shareable', {key => unique_glue('test02'), destroy => 1, serializer => 'storable' }; 1; }; is $ok, undef, "We croak ok if create is not set and segment doesn't yet exist"; like $@, qr/Could not acquire/, "...and error is sane."; IPC::Shareable::_end; assert_clean_process(); done_testing; IPC-Shareable-1.19/t/56-singleton_class.t000644 000765 000024 00000001674 15207650136 020320 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process); # bad param my $ok = eval { IPC::Shareable::singleton(); 1 }; is $ok, undef, "singleton() croaks if no GLUE param sent in"; like $@, qr/GLUE parameter/, "...and error is sane"; # singleton no exit notice my ($proc, $warning); { local $SIG{__WARN__} = sub {$warning = shift;}; $proc = IPC::Shareable::singleton('LOCK'); is $proc, $$, "Class param is added if called in IPC::Shareable::singleton() format"; $proc = -1; is $proc, -1, "\$proc set to -1 ok"; $proc = IPC::Shareable::singleton('LOCK'); } END { is $proc, -1, "singleton() on second call doesn't return anything ok"; is $warning, undef, "singleton outputs no warnings by default"; IPC::Shareable::_end; assert_clean_process(); done_testing; }; IPC-Shareable-1.19/t/PaxHeader/72-shm_segments.t000644 000765 000024 00000000207 15222763263 021566 xustar00stevestaff000000 000000 29 mtime=1783359155.48796344 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/72-shm_segments.t000644 000765 000024 00000034341 15222763263 017623 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use IPC::SysV qw(IPC_CREAT IPC_RMID); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue require_free_sem_sets); require_free_sem_sets(); # All keys are per-run unique (so two smokers running this file at once don't # collide on the same System V segment). hexkey() returns the lowercase # '0x........' string shm_segments() keys each entry by, computed from a glue # (or integer) exactly the way the module does. See hexkey() at end of file. # 0x1B0B0001-equivalent: referenced from two subtests, so defined up here. my $basic_glue = unique_glue('shmseg_basic'); my $basic_hex = hexkey($basic_glue); # ----------------------------------------------------------------------- # shm_segments() - basic return type # ----------------------------------------------------------------------- { my $segs = IPC::Shareable->shm_segments; is ref($segs), 'HASH', "shm_segments() returns a hash ref"; } # ----------------------------------------------------------------------- # shm_segments() - IPC::Shareable segments appear, keyed by hex string # ----------------------------------------------------------------------- { tie my %h, 'IPC::Shareable', { key => $basic_glue, create => 1, destroy => 1 , serializer => 'storable' }; $h{test} = 'hello'; my $segs = IPC::Shareable->shm_segments; ok exists $segs->{$basic_hex}, "IPC::Shareable segment appears in shm_segments() output"; is ref($segs->{$basic_hex}), 'HASH', "...each entry is a hash ref"; like $segs->{$basic_hex}{content}, qr/^IPC::Shareable/, "...segment content starts with 'IPC::Shareable' tag"; is $segs->{$basic_hex}{local_process}, 1, "...local_process flag is set for this process's segment"; is $segs->{$basic_hex}{known}, 1, "...known is 1 for a segment tied in this process"; } # ----------------------------------------------------------------------- # shm_segments() - non-IPC::Shareable segment is skipped # ----------------------------------------------------------------------- { my $foreign_key = IPC::Shareable::_key_str_to_int(unique_glue('shmseg_foreign')); my $foreign_hex = hexkey($foreign_key); my $id = shmget($foreign_key, 64, IPC_CREAT | 0666); ok defined($id), "created a raw (non-IPC::Shareable) segment with shmget() ok"; shmwrite($id, 'plain foreign data', 0, 64); my $segs = IPC::Shareable->shm_segments; ok !exists $segs->{$foreign_hex}, "shm_segments() skips segment not tagged with 'IPC::Shareable' prefix"; # clean up the foreign segment my $removed = shmctl($id, IPC_RMID, 0); ok $removed, "foreign segment cleaned up ok"; } # ----------------------------------------------------------------------- # shm_segments() - returns the correct number of IPC::Shareable segments # ----------------------------------------------------------------------- { my $scalar_glue = unique_glue('shmseg_scalar'); my $scalar_hex = hexkey($scalar_glue); my $hash_glue = unique_glue('shmseg_hash'); my $hash_hex = hexkey($hash_glue); my $count_before = scalar keys %{ IPC::Shareable->shm_segments }; tie my $sv, 'IPC::Shareable', { key => $scalar_glue, create => 1, destroy => 1 , serializer => 'storable' }; $sv = 'scalar value'; tie my %hv, 'IPC::Shareable', { key => $hash_glue, create => 1, destroy => 1 , serializer => 'storable' }; $hv{x} = 1; my $segs = IPC::Shareable->shm_segments; my $count_after = scalar keys %$segs; cmp_ok $count_after, '>=', $count_before + 2, "shm_segments() count increases by at least 2 after creating 2 segments"; ok exists $segs->{$scalar_hex}, "scalar segment key present ok"; ok exists $segs->{$hash_hex}, "hash segment key present ok"; is $segs->{$scalar_hex}{local_process}, 1, "scalar segment local_process flag set ok"; is $segs->{$hash_hex}{local_process}, 1, "hash segment local_process flag set ok"; } # ----------------------------------------------------------------------- # shm_segments() - keys are lowercase hex strings # ----------------------------------------------------------------------- { my $glue = unique_glue('shmseg_lower'); my $hex = hexkey($glue); tie my %h, 'IPC::Shareable', { key => $glue, create => 1, destroy => 1 , serializer => 'storable' }; $h{v} = 1; my $segs = IPC::Shareable->shm_segments; my @non_lower = grep { $_ ne lc($_) } keys %$segs; is scalar(@non_lower), 0, "all keys in shm_segments() are lowercase hex strings"; my @missing_flags = grep { !exists $segs->{$_}{child_keys} || !exists $segs->{$_}{content} || !exists $segs->{$_}{local_process} || !exists $segs->{$_}{known} } keys %$segs; is scalar(@missing_flags), 0, "all entries have child_keys/content/local_process/known keys"; is_deeply $segs->{$hex}{child_keys}, [], "child_keys is empty arrayref for segment with no children"; } # ----------------------------------------------------------------------- # shm_segments() - child_keys is an arrayref of child hex keys when # a JSON segment has nested children # ----------------------------------------------------------------------- { my $glue = unique_glue('shmseg_jsonchild'); my $hex = hexkey($glue); tie my %h, 'IPC::Shareable', { key => $glue, create => 1, destroy => 1, serializer => 'json' }; $h{a} = 1; $h{b} = { x => 10 }; # nested hash → child segment my $segs = IPC::Shareable->shm_segments; ok exists $segs->{$hex}, "parent segment with JSON child is present"; my $ck = $segs->{$hex}{child_keys}; is ref($ck), 'ARRAY', "child_keys is an arrayref for segment with children"; is scalar(@$ck), 1, "...with exactly one child key"; like $ck->[0], qr/^0x[0-9a-f]+$/, "...child key is a hex string"; } # ----------------------------------------------------------------------- # shm_segments() - known => 0 for an IPC::Shareable-tagged segment # that is not in any register (simulates a leftover from a dead process) # ----------------------------------------------------------------------- { my $orphan_key = IPC::Shareable::_key_str_to_int(unique_glue('shmseg_orphan')); my $orphan_hex = hexkey($orphan_key); # Create a segment manually and write the IPC::Shareable tag prefix, # but never register it — so it will appear as known => 0. my $id = shmget($orphan_key, 128, IPC_CREAT | 0666); ok defined($id), "created unregistered-simulating segment with shmget() ok"; my $tag = 'IPC::Shareable' . 'fake_orphan_data'; shmwrite($id, $tag, 0, 128); my $segs = IPC::Shareable->shm_segments; ok exists $segs->{$orphan_hex}, "unregistered segment appears in shm_segments() output"; is $segs->{$orphan_hex}{known}, 0, "...known is 0 for unregistered segment"; is $segs->{$orphan_hex}{local_process}, 0, "...local_process is 0 for unregistered segment"; # unknown_segments() method my @unknown = IPC::Shareable->unknown_segments; ok scalar(@unknown) >= 1, "unknown_segments() returns at least one entry"; ok grep({ $_ eq $orphan_hex } @unknown), "unknown_segments() includes the unregistered segment key"; ok !grep({ $_ eq $basic_hex } @unknown), "unknown_segments() excludes a registered segment"; shmctl($id, IPC_RMID, 0); } # ----------------------------------------------------------------------- # remove() - class method with key, all key format variants # Each creates a tagged-but-unregistered segment, then removes it via # IPC::Shareable->remove($key) and confirms it is gone from shm_segments() # ----------------------------------------------------------------------- { # text key: gets CRC'd internally — ask the module for the resulting int my $text_key = unique_glue('shmseg_removetext'); my $text_int = IPC::Shareable->_shm_key($text_key); my $text_hex = hexkey($text_key); my $id1 = shmget($text_int, 128, IPC_CREAT | 0666); shmwrite($id1, 'IPC::Shareablefake', 0, 128); ok exists(IPC::Shareable->shm_segments->{$text_hex}), "text key: segment exists before remove()"; IPC::Shareable->remove($text_key); ok !exists(IPC::Shareable->shm_segments->{$text_hex}), "text key: gone after IPC::Shareable->remove(text key)"; # integer key: decimal integer, used as-is my $int_key = IPC::Shareable::_key_str_to_int(unique_glue('shmseg_removeint')); my $int_hex = hexkey($int_key); my $id2 = shmget($int_key, 128, IPC_CREAT | 0666); shmwrite($id2, 'IPC::Shareablefake', 0, 128); ok exists(IPC::Shareable->shm_segments->{$int_hex}), "int key: segment exists before remove()"; IPC::Shareable->remove($int_key); ok !exists(IPC::Shareable->shm_segments->{$int_hex}), "int key: gone after IPC::Shareable->remove(integer)"; # hex literal key: an integer that you'd write as 0x... in source — at # runtime it is just an integer, so it takes the same path as an int key my $hex_lit_int = IPC::Shareable::_key_str_to_int(unique_glue('shmseg_removehexlit')); my $hex_lit_hex = hexkey($hex_lit_int); my $id3 = shmget($hex_lit_int, 128, IPC_CREAT | 0666); shmwrite($id3, 'IPC::Shareablefake', 0, 128); ok exists(IPC::Shareable->shm_segments->{$hex_lit_hex}), "hex literal key: segment exists before remove()"; IPC::Shareable->remove($hex_lit_int); ok !exists(IPC::Shareable->shm_segments->{$hex_lit_hex}), "hex literal key: gone after IPC::Shareable->remove(0x... integer)"; # hex string key: string of the form '0x...' my $hex_str_key = hexkey(unique_glue('shmseg_removehexstr')); # '0x........' my $hex_str_hex = lc($hex_str_key); my $id4 = shmget(hex($hex_str_key), 128, IPC_CREAT | 0666); shmwrite($id4, 'IPC::Shareablefake', 0, 128); ok exists(IPC::Shareable->shm_segments->{$hex_str_hex}), "hex string key: segment exists before remove()"; IPC::Shareable->remove($hex_str_key); ok !exists(IPC::Shareable->shm_segments->{$hex_str_hex}), "hex string key: gone after IPC::Shareable->remove('0x...')"; } # ----------------------------------------------------------------------- # unknown_segments() - fork-and-exit produces a real orphan from the # parent's point of view. The child creates a tied segment with # destroy => 0 and exits; the parent never tied the key, so its # global_register has no entry for it. # ----------------------------------------------------------------------- { my $orphan_glue = unique_glue('shmseg_forkorphan'); my $orphan_hex = hexkey($orphan_glue); pipe(my $r, my $w) or die "pipe: $!"; my $pid = fork; defined $pid or die "fork: $!"; if ($pid == 0) { close $r; tie my %h, 'IPC::Shareable', { key => $orphan_glue, create => 1, exclusive => 1, destroy => 0, serializer => 'storable', }; $h{leftover} = 1; print $w "created\n"; close $w; exit 0; } close $w; my $line = <$r>; close $r; waitpid($pid, 0); my @unknown = IPC::Shareable->unknown_segments; ok scalar(grep { $_ eq $orphan_hex } @unknown), "unknown_segments(): fork+exit orphan key present from parent's view"; IPC::Shareable->remove($orphan_glue); ok !exists(IPC::Shareable->shm_segments->{$orphan_hex}), "fork+exit orphan: removed via remove(\$key) ok"; } IPC::Shareable::_end; assert_clean_process(); # ----------------------------------------------------------------------- # shm_segments() and unknown_segments() called as object methods # ----------------------------------------------------------------------- { my $glue = unique_glue('shmseg_objmethod'); my $hex = hexkey($glue); my $k = tie my %h, 'IPC::Shareable', { key => $glue, create => 1, destroy => 1 , serializer => 'storable' }; $h{x} = 1; my $segs = $k->shm_segments; is ref($segs), 'HASH', "shm_segments() as object method returns hash ref"; ok exists $segs->{$hex}, "shm_segments() as object method shows our segment"; my @unknown = $k->unknown_segments; ok !grep({ $_ eq $hex } @unknown), "unknown_segments() as object method excludes our registered segment"; IPC::Shareable->clean_up_all; } # ----------------------------------------------------------------------- # shm_segments($filter_key) - filter to a specific segment tree # ----------------------------------------------------------------------- { # Create two unrelated segments plus a parent-with-child (JSON serializer # creates child segments for nested refs). my $parent_glue = unique_glue('shmseg_filterparent'); my $parent_hex = hexkey($parent_glue); my $other_glue = unique_glue('shmseg_filterother'); my $other_hex = hexkey($other_glue); tie my %parent, 'IPC::Shareable', { key => $parent_glue, create => 1, destroy => 1, serializer => 'json', }; tie my %other, 'IPC::Shareable', { key => $other_glue, create => 1, destroy => 1, serializer => 'storable', }; $parent{child} = { nested => 1 }; # creates a child segment $other{x} = 1; # Filter to just the parent key — should include parent and its child, # but not the unrelated segment. my $filtered = IPC::Shareable->shm_segments($parent_glue); is ref($filtered), 'HASH', "shm_segments(filter) returns a hash ref"; ok exists $filtered->{$parent_hex}, "shm_segments(filter) includes the requested segment"; ok !exists $filtered->{$other_hex}, "shm_segments(filter) excludes unrelated segment"; # Filter to a key that doesn't exist — should return an empty hash. my $empty = IPC::Shareable->shm_segments(unique_glue('shmseg_nonexistent')); is ref($empty), 'HASH', "shm_segments(nonexistent filter) still returns a hash ref"; is scalar(keys %$empty), 0, "shm_segments(nonexistent filter) returns empty hash"; IPC::Shareable->clean_up_all; } done_testing; # Lowercase '0x........' string for a glue or integer, matching how # shm_segments() keys its output (sprintf '0x%08x' of the integer key). sub hexkey { return sprintf '0x%08x', IPC::Shareable::_key_str_to_int($_[0]); } IPC-Shareable-1.19/t/PaxHeader/05-shm_stat.t000644 000765 000024 00000000210 15222763263 020702 xustar00stevestaff000000 000000 30 mtime=1783359155.486166648 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/05-shm_stat.t000644 000765 000024 00000006036 15222763263 016745 0ustar00stevestaff000000 000000 use strict; use warnings; use Data::Dumper; use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue require_free_sem_sets); require_free_sem_sets(); use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); my $mod = 'IPC::Shareable'; my $knot = tie my %hv, $mod, { create => 1, key => unique_glue('k1234'), destroy => 1, }; my $seg = $knot->seg; my $stats = $seg->stats; my @stat_list = IPC::Shareable::SharedMem::stat_list(); for (@stat_list) { my $data = $seg->stat->$_; like $data, qr/^\d+$/, "$_ segment stat returned an integer properly"; is $data, $stats->{$_}, "stats() and stat $_ method data lines up ok"; } # Verify segsz matches what we requested (catches platform-specific # shmid_ds unpack bugs like the 64-bit Solaris/illumos offset fix). cmp_ok $seg->stat->segsz, '>=', IPC::Shareable::SHM_BUFSIZ, 'segsz from stat() is at least the requested segment size'; $hv{a} = {b => {c => 1}}; # print Dumper \%hv; # print Dumper $knot->seg->stats; #print Dumper $stats; #print Dumper $knot; #print Dumper $seg; { # nattch tracks processes currently holding a shmat() attachment. # Perl's shmread/shmwrite are atomic at the C level (shmat -> op -> shmdt), # so nattch is always 0 by the time control returns to Perl -- there is no # Perl-visible moment where the segment is "still attached". my $knot2 = tie my %hv2, $mod, { create => 1, key => unique_glue('k5678'), destroy => 1 }; my $seg2 = $knot2->seg; is $seg2->stat->nattch, 0, 'nattch is 0 before any I/O'; $hv2{a} = 1; $hv2{b} = 2; my $val = $hv2{a}; is $seg2->stat->nattch, 0, 'nattch is 0 after writes+read complete: shmat+shmdt finish inside shmread/shmwrite before Perl sees the result'; is $seg2->stat->cpid, $$, 'cpid matches current PID'; is $seg2->stat->lpid, $$, 'lpid matches current PID after I/O'; } SKIP: { skip 'nattch > 0 test requires RELEASE_TESTING=1', 2 unless $ENV{RELEASE_TESTING}; # To observe nattch > 0 we must hold an shmat() attachment open at the # Perl level, which requires calling shmat(2) directly via Inline::C. # Perl's own shmread/shmwrite complete the full shmat->op->shmdt cycle # inside a single C function, so nattch is never > 0 from pure Perl. require Inline; Inline->import(C => <<'END_C'); #include #include #include void* shmat_hold(int id) { return shmat(id, NULL, 0); } void shmdt_release(void* addr) { shmdt(addr); } END_C my $knot3 = tie my %hv3, $mod, { create => 1, key => unique_glue('k9012'), destroy => 1 }; my $seg3 = $knot3->seg; my $addr = shmat_hold($seg3->id); is $seg3->stat->nattch, 1, 'nattch is 1 while shmat() attachment is held open via Inline::C'; shmdt_release($addr); is $seg3->stat->nattch, 0, 'nattch drops back to 0 after shmdt()'; } IPC::Shareable->clean_up_all; is %hv, '', "hash deleted after clean_up()"; IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/18-fork_ipc.t000644 000765 000024 00000004141 15211722360 016705 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use Test::SharedFork; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw( assert_clean barrier_new barrier_release barrier_wait unique_glue ); # serializer: storable { my $ready = barrier_new(); # parent -> child: segment created my $pid = fork; defined $pid or die "Cannot fork: $!"; if ($pid == 0) { # child barrier_wait($ready); tie my %h, 'IPC::Shareable', { key => unique_glue('testing25'), destroy => 0 , serializer => 'storable' }; $h{a} = 'foo'; exit; } else { # parent tie my %h, 'IPC::Shareable', { key => unique_glue('testing25'), create => 1, destroy => 1, serializer => 'storable', }; $h{a} = 'bar'; is $h{a}, 'bar', "storable: in parent: parent set HV to 'bar' ok"; barrier_release($ready); waitpid($pid, 0); is $h{a}, 'foo', "storable: in parent: child set HV to 'foo' ok"; IPC::Shareable->clean_up_all; } } # serializer: json { my $ready = barrier_new(); # parent -> child: segment created my $pid = fork; defined $pid or die "Cannot fork: $!"; if ($pid == 0) { # child barrier_wait($ready); tie my %h, 'IPC::Shareable', { key => unique_glue('testing25j'), destroy => 0, serializer => 'json' }; $h{a} = 'foo'; exit; } else { # parent tie my %h, 'IPC::Shareable', { key => unique_glue('testing25j'), create => 1, destroy => 1, serializer => 'json', }; $h{a} = 'bar'; is $h{a}, 'bar', "json: in parent: parent set HV to 'bar' ok"; barrier_release($ready); waitpid($pid, 0); is $h{a}, 'foo', "json: in parent: child set HV to 'foo' ok"; IPC::Shareable->clean_up_all; } } IPC::Shareable::_end; assert_clean(unique_glue('testing25'), unique_glue('testing25j')); done_testing(); IPC-Shareable-1.19/t/PaxHeader/42-seg_sem.t000644 000765 000024 00000000210 15222763263 020503 xustar00stevestaff000000 000000 30 mtime=1783359155.487305606 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/42-seg_sem.t000644 000765 000024 00000003566 15222763263 016553 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use Data::Dumper; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue require_free_sem_sets); require_free_sem_sets(); my $k = tie my %hv, 'IPC::Shareable', unique_glue('test'), { create => 1, destroy => 1 , serializer => 'storable' }; # seg() my @seg_keys = qw( id key key_hex flags mode type size ); my $knot_seg = $k->seg; my $tied_seg = (tied %hv)->seg; is ref $knot_seg, 'IPC::Shareable::SharedMem', "knot seg() is the proper object"; is ref $tied_seg, 'IPC::Shareable::SharedMem', "tied seg() is the proper object"; is keys %$knot_seg, scalar @seg_keys, "knot hash has the proper number of keys"; is keys %$tied_seg, scalar @seg_keys, "tied hash has the proper number of keys"; for (@seg_keys) { is exists $knot_seg->{$_}, 1, "$_ key exists in knot hash ok"; is exists $tied_seg->{$_}, 1, "$_ key exists in tied hash ok"; } is $knot_seg->id, $tied_seg->id, "knot and tied seg() hashes have the same id"; $hv{a}->{b}{c} = 143; my $top_level_seg = tied(%hv)->seg; my $bot_level_seg = tied(%{ $hv{a}->{b} })->seg; isnt $top_level_seg->id, $bot_level_seg->id, "top level and bot level seg() hashes have different ids"; # sem() my $knot_sem = $k->sem(); my $tied_sem = (tied %hv)->sem; is ref $knot_sem, 'IPC::Semaphore', "knot sem() is the proper object"; is ref $tied_sem, 'IPC::Semaphore', "tied sem() is the proper object"; is $knot_sem->id, $tied_sem->id, "knot and tied sem() hashes have the same id"; my $top_level_sem = tied(%hv)->sem; my $bot_level_sem = tied(%{ $hv{a}->{b} })->sem; print Dumper $top_level_sem; isnt $top_level_sem->id, $bot_level_sem->id, "top level and bot level sem() hashes have different ids"; IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/00-base.t000644 000765 000024 00000007652 15222763141 016030 0ustar00stevestaff000000 000000 use warnings; use strict; use Data::Dumper; use IPC::Semaphore; use IPC::SysV qw(IPC_RMID); use Test::More; BEGIN { use_ok('IPC::Shareable'); }; # Clear stale testing segments left behind by a previously crashed run. # clean_up_testing() only removes segments this process created or whose creator # process has exited, so it is safe to run even under a parallel harness -- it # will not touch a concurrently-running sibling test file's live segments. IPC::Shareable->clean_up_testing('IPC::Shareable'); # The async_tests pair needs its own reclaim by name: a leftover from a pre-1.18 # suite has a 4-slot semaphore set with no SEM_TESTING marker, so # clean_up_testing() cannot prove it is ours. Only this suite ever uses the # 'async_tests' glue, and the creator-alive check leaves a concurrently-running # sibling suite alone. _reclaim_stale_async_tests(); IPC::Shareable->testing_set('IPC::Shareable'); # The whole-suite *count* comparison (below, and in t/99-end) is still inherently # global, so it stays serial-only: skip it under a parallel harness (eg. a # smoker running with HARNESS_OPTIONS=jN). my $parallel = defined $ENV{HARNESS_OPTIONS} && $ENV{HARNESS_OPTIONS} =~ /(?:^|:)j[0-9]/; my $segs_before = IPC::Shareable::seg_count(); my $sems_before = IPC::Shareable::sem_count(); warn "Segs Before: $segs_before\n" if $ENV{PRINT_SEGS}; print "Starting with $segs_before segments\n"; is $segs_before, $segs_before, "Initial test ok"; # If an async_tests segment still exists here (live sibling suite, or a stale # one whose creator appears alive), the tie below ATTACHES instead of creating, # and the end-of-file count check must not expect a new segment. my $async_existed = defined shmget(IPC::Shareable::_key_str_to_int('async_tests'), 0, 0) ? 1 : 0; tie my %store, 'IPC::Shareable', {key => 'async_tests', create => 1, serializer => 'storable' }; # Measure the baseline AFTER tying and subtract 1 to exclude the async_tests # segment/semaphore themselves. This keeps t/99-end.t's comparison correct # even when a stale async_tests semaphore was orphaned by a previous crashed # run (segment removed, semaphore not), causing the pre-tie count to be off. $store{segs} = IPC::Shareable::seg_count() - 1; $store{sems} = IPC::Shareable::sem_count() - 1; { my $a = tie my $x, 'IPC::Shareable'; my $b = tie my $y, 'IPC::Shareable', { create => 1, destroy => 1 , serializer => 'storable' }; is $a->{_key}, 0, "tie with no glue or options is IPC_PRIVATE ok"; is $b->{_key}, 0, "tie with no glue but with options is IPC_PRIVATE ok"; $a->remove; } IPC::Shareable::_end; warn "Segs After: " . IPC::Shareable::seg_count() . "\n" if $ENV{PRINT_SEGS}; SKIP: { skip "whole-suite IPC count check is serial-only (parallel harness detected)", 1 if $parallel; is IPC::Shareable::seg_count(), $segs_before + ($async_existed ? 0 : 1), "No segs left after test suite run ok"; } done_testing(); # Remove a stale async_tests segment and/or semaphore set left by a previous # crashed run, whatever its vintage (marked or not). The segment is only # removed when its creator process has exited -- same ownership rule as # clean_up_testing(). An async_tests semaphore with no segment is always a # broken pair (the segment is created first, removed first), so it is removed # unconditionally. sub _reclaim_stale_async_tests { my $key_int = IPC::Shareable::_key_str_to_int('async_tests'); my $id = shmget($key_int, 0, 0); if (defined $id) { my $probe = bless {}, 'IPC::Shareable::SharedMem'; $probe->id($id); my $stat = eval { $probe->stat }; my $cpid = defined $stat ? $stat->cpid : undef; # Creator still alive: a sibling suite run owns it; leave the pair alone return if defined $cpid && $cpid > 0 && $cpid != $$ && kill 0, $cpid; shmctl($id, IPC_RMID, 0); } my $sem = IPC::Semaphore->new($key_int, 0, 0); $sem->remove if defined $sem; return; } IPC-Shareable-1.19/t/PaxHeader/11-av.t000644 000765 000024 00000000210 15222763263 017463 xustar00stevestaff000000 000000 30 mtime=1783359155.486431106 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/11-av.t000644 000765 000024 00000012231 15222763263 015520 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue require_free_sem_sets); require_free_sem_sets(); my $mod = 'IPC::Shareable'; # serializer: storable { tie my @av, $mod, { key => unique_glue('av11'), create => 1, destroy => 1 }; my @words = qw(tic tac toe); @av = qw(tic tac toe); for (0 .. 2) { is $av[$_], $words[$_], "storable: shared array populated ok: $_"; } $#av = 5; is scalar(@av), 6, "storable: array count ok"; for (3 .. 5) { is defined $av[$_], '', "storable: array elem $_ is present but undefined"; } is $#av, 5, "storable: array len ok"; @av = (); is scalar(@av), 0, "storable: shared array cleared ok"; @av = qw(fee fie foe fum); my $fum = pop @av; is $fum, 'fum', "storable: pop ok"; is $#av, 2, "storable: after pop, proper element count ok"; push @av => $fum; is $av[3], $fum, "storable: push ok"; is $#av, 3, "storable: push adds element ok"; my $fee = shift @av; is $fee, 'fee', "storable: shift ok"; is $#av, 2, "storable: after shift, proper element count ok"; unshift @av => $fee; is $fee, 'fee', "storable: unshift ok"; is $#av, 3, "storable: after unshift, proper element count ok"; my (@gone) = splice @av, 1, 2, qw(i spliced); is $av[1], 'i', "storable: splice 1 ok"; is $av[2], 'spliced', "storable: splice 2 ok"; is $gone[0], 'fie', "storable: splice 3 ok"; is $gone[1], 'foe', "storable: splice 4 ok"; # --- nested structures @av = (); # arrayref element $av[0] = [10, 20, 30]; is ref($av[0]), 'ARRAY', "storable: nested arrayref element ok"; is $av[0][1], 20, "storable: nested arrayref element value ok"; # hashref element $av[1] = { name => 'perl', version => 5 }; is ref($av[1]), 'HASH', "storable: nested hashref element ok"; is $av[1]{name}, 'perl', "storable: nested hashref element value ok"; # deeper nesting: hashref containing arrayref $av[2] = { list => [1, 2, 3], meta => { ok => 1 } }; is ref($av[2]{list}), 'ARRAY', "storable: deep nested arrayref ok"; is $av[2]{list}[2], 3, "storable: deep nested arrayref value ok"; is $av[2]{meta}{ok}, 1, "storable: deep nested hashref value ok"; # array of arrayrefs $av[3] = [[qw(a b)], [qw(c d)]]; is $av[3][0][1], 'b', "storable: array of arrayrefs ok"; is $av[3][1][0], 'c', "storable: array of arrayrefs second element ok"; IPC::Shareable->clean_up_all; } # serializer: json { tie my @av, $mod, { key => unique_glue('av11'), create => 1, destroy => 1, serializer => 'json' }; my @words = qw(tic tac toe); @av = qw(tic tac toe); for (0 .. 2) { is $av[$_], $words[$_], "json: shared array populated ok: $_"; } $#av = 5; is scalar(@av), 6, "json: array count ok"; for (3 .. 5) { is defined $av[$_], '', "json: array elem $_ is present but undefined"; } is $#av, 5, "json: array len ok"; @av = (); is scalar(@av), 0, "json: shared array cleared ok"; @av = qw(fee fie foe fum); my $fum = pop @av; is $fum, 'fum', "json: pop ok"; is $#av, 2, "json: after pop, proper element count ok"; push @av => $fum; is $av[3], $fum, "json: push ok"; is $#av, 3, "json: push adds element ok"; my $fee = shift @av; is $fee, 'fee', "json: shift ok"; is $#av, 2, "json: after shift, proper element count ok"; unshift @av => $fee; is $fee, 'fee', "json: unshift ok"; is $#av, 3, "json: after unshift, proper element count ok"; my (@gone) = splice @av, 1, 2, qw(i spliced); is $av[1], 'i', "json: splice 1 ok"; is $av[2], 'spliced', "json: splice 2 ok"; is $gone[0], 'fie', "json: splice 3 ok"; is $gone[1], 'foe', "json: splice 4 ok"; # --- nested structures @av = (); # arrayref element $av[0] = [10, 20, 30]; is ref($av[0]), 'ARRAY', "json: nested arrayref element ok"; is $av[0][1], 20, "json: nested arrayref element value ok"; # hashref element $av[1] = { name => 'perl', version => 5 }; is ref($av[1]), 'HASH', "json: nested hashref element ok"; is $av[1]{name}, 'perl', "json: nested hashref element value ok"; # deeper nesting: hashref containing arrayref $av[2] = { list => [1, 2, 3], meta => { ok => 1 } }; is ref($av[2]{list}), 'ARRAY', "json: deep nested arrayref ok"; is $av[2]{list}[2], 3, "json: deep nested arrayref value ok"; is $av[2]{meta}{ok}, 1, "json: deep nested hashref value ok"; # array of arrayrefs $av[3] = [[qw(a b)], [qw(c d)]]; is $av[3][0][1], 'b', "json: array of arrayrefs ok"; is $av[3][1][0], 'c', "json: array of arrayrefs second element ok"; IPC::Shareable->clean_up_all; } # FETCH from a never-written array segment returns undef (empty segment path) { tie my @av, $mod, { key => unique_glue('av11e'), create => 1, destroy => 1 }; is $av[0], undef, "FETCH on never-written array element returns undef ok"; } IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/86-exports.t000644 000765 000024 00000011550 15206611736 016634 0ustar00stevestaff000000 000000 use warnings; use strict; use Test::More; use IPC::Shareable (); # -- Expected exports by tag -- my %expected = ( all => [qw(LOCK_EX LOCK_SH LOCK_NB LOCK_UN SEM_MARKER SEM_READERS SEM_WRITERS SEM_PROTECTED SEM_TESTING)], lock => [qw(LOCK_EX LOCK_SH LOCK_NB LOCK_UN)], flock => [qw(LOCK_EX LOCK_SH LOCK_NB LOCK_UN)], semaphores => [qw(SEM_MARKER SEM_READERS SEM_WRITERS SEM_PROTECTED SEM_TESTING)], ); # Unique, sorted list of every exportable symbol my @all_unique = sort keys %{ { map { $_ => 1 } map { @$_ } values %expected } }; # -- Structural integrity -- subtest 'structural integrity' => sub { # All expected tags exist in the module is_deeply( [sort keys %IPC::Shareable::EXPORT_TAGS], [sort keys %expected], 'All expected export tags are defined in %EXPORT_TAGS', ); # @EXPORT_OK must have no duplicates and match the union of all tag exports { my %seen; my @dupes = grep { $seen{$_}++ } @IPC::Shareable::EXPORT_OK; ok(! @dupes, '@EXPORT_OK has no duplicate symbols') or diag "Duplicates: @dupes"; is_deeply( [sort @IPC::Shareable::EXPORT_OK], [sort @all_unique], '@EXPORT_OK contains exactly the union of all tag exports', ); } # Every symbol in @EXPORT_OK is covered by at least one tag { my %tag_items = map { $_ => 1 } map { @$_ } values %IPC::Shareable::EXPORT_TAGS; my @uncovered = sort grep { ! $tag_items{$_} } keys %{ { map { $_ => 1 } @IPC::Shareable::EXPORT_OK } }; ok(! @uncovered, 'Every symbol in @EXPORT_OK is covered by at least one tag') or diag "Uncovered: @uncovered"; } # No tag references symbols outside @EXPORT_OK { my %ok = map { $_ => 1 } @IPC::Shareable::EXPORT_OK; for my $tag (sort keys %{ $IPC::Shareable::EXPORT_TAGS }) { my @extra = grep { ! $ok{$_} } @{ $IPC::Shareable::EXPORT_TAGS{$tag} }; ok(! @extra, ":$tag contains only symbols from \@EXPORT_OK") or diag "Extra in :$tag: @extra"; } } }; # -- :lock and :flock are equivalent -- subtest ':lock and :flock are equivalent' => sub { is_deeply( [sort @{ $IPC::Shareable::EXPORT_TAGS{lock} }], [sort @{ $IPC::Shareable::EXPORT_TAGS{flock} }], ':lock and :flock contain identical symbols', ); }; # -- Each tag imports exactly what it should, with correct values -- for my $tag (sort keys %expected) { subtest ":${tag} tag" => sub { my @want = sort @{ $expected{$tag} }; my $pkg = fresh_pkg(); _do_import($pkg, ":$tag"); my @got = sort(imported_from($pkg)); is_deeply(\@got, \@want, ":$tag imports exactly the expected symbols") or diag explain { want => \@want, got => \@got }; for my $sym (@want) { my ($got_val, $want_val) = symbol_values($pkg, $sym); is $got_val, $want_val, "$sym == $want_val"; } }; } # -- Each symbol can be imported individually -- for my $sym (@all_unique) { subtest "import '$sym'" => sub { my $pkg = fresh_pkg(); _do_import($pkg, $sym); my @got = sort(imported_from($pkg)); is_deeply(\@got, [$sym], "importing '$sym' exports only '$sym'"); my ($got_val, $want_val) = symbol_values($pkg, $sym); is $got_val, $want_val, "$sym == $want_val"; }; } # -- Importing everything at once (as a whole) -- subtest 'import all symbols individually in one use statement' => sub { my $pkg = fresh_pkg(); _do_import($pkg, @all_unique); my @got = sort(imported_from($pkg)); is_deeply(\@got, [sort @all_unique], 'importing all symbols individually gives complete set'); for my $sym (@all_unique) { my ($got_val, $want_val) = symbol_values($pkg, $sym); is $got_val, $want_val, "$sym == $want_val"; } }; subtest 'import via multiple tags at once' => sub { my $pkg = fresh_pkg(); _do_import($pkg, ':lock', ':semaphores'); my @got = sort(imported_from($pkg)); is_deeply(\@got, [sort @all_unique], 'importing :lock + :semaphores gives the full set'); for my $sym (@all_unique) { my ($got_val, $want_val) = symbol_values($pkg, $sym); is $got_val, $want_val, "$sym == $want_val"; } }; done_testing; # -- helpers -- { my $n = 0; sub fresh_pkg { 'IPC_Shareable_Test_Exports_' . ++$n } } sub _do_import { my ($pkg, @args) = @_; my $args_str = join ', ', map { "'$_'" } @args; eval qq{ package $pkg; require IPC::Shareable; IPC::Shareable->import($args_str); 1; } or die "$@"; } sub imported_from { my ($pkg) = @_; no strict 'refs'; return grep { $pkg->can($_) } @all_unique; } sub symbol_values { my ($pkg, $sym) = @_; no strict 'refs'; return ($pkg->can($sym)->(), IPC::Shareable->can($sym)->()); }IPC-Shareable-1.19/t/47-seg_size.t000644 000765 000024 00000005703 15207650136 016736 0ustar00stevestaff000000 000000 use warnings; use strict; use Config; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process); BEGIN { if ($Config{ivsize} < 8) { plan skip_all => "This test script can't be run on a perl < 64-bit"; } } use constant BYTES => 2000000; # ~2MB # limit { my $size_ok_limit = eval { tie my $var, 'IPC::Shareable', { create => 1, size => 2_000_000_000, destroy => 1, serializer => 'storable', }; 1; }; is $size_ok_limit, undef, "size larger than MAX croaks ok"; like $@, qr/larger than max size/, "...and error is sane"; if ($ENV{IPC_MEM}) { my $size_ok_no_limit = eval { tie my $var, 'IPC::Shareable', { limit => 0, create => 1, size => 2_000_000_000, destroy => 1, serializer => 'storable', }; 1; }; is $size_ok_no_limit, 1, "size larger than MAX succeeeds with limit=>0 ok"; } else { warn "IPC_MEM env var not set, skipping the exhaust memory test\n"; } } # beyond RAM limits # # With limit => 0 the module's own size guard is disabled, so this relies on # the OS rejecting an absurdly large segment. That only holds where size_t is # 64-bit: on a 32-bit size_t (eg. i686 perls built with use64bitint, whose # ivsize is 8 so the skip at the top of this file does not catch them) the # requested size wraps modulo 2**32 to an allocatable value and the tie # succeeds, so skip these two checks there. SKIP: { skip "32-bit size_t wraps a > 4 GB segment size instead of failing", 2 if $Config{sizesize} < 8; my $size_ok = eval { tie my $var, 'IPC::Shareable', { limit => 0, size => 999999999999, destroy => 1, serializer => 'storable', }; 1; }; is $size_ok, undef, "We croak if size is greater than max RAM"; like $@, qr/Could not (?:create|acquire) shared memory/, "...and error is sane"; } my $k = tie my %hv, 'IPC::Shareable', { create => 1, destroy => 1, size => BYTES, serializer => 'storable', }; my $seg = $k->seg; my $id = $seg->id; my $size = $seg->size; my $actual_size; if ($^O eq 'linux') { my $record = `ipcs -m -i $id`; $actual_size = 0; if ($record =~ /bytes=(\d+)/s) { $actual_size = $1; } } else { $actual_size = 0; } is BYTES, $size, "size param is the same as the segment size"; # ipcs -i doesn't work on MacOS or FreeBSD, so skip it for now TODO: { local $TODO = 'Not yet working on FreeBSD or macOS'; }; # ...and only run it on Linux systems if ($^O eq 'linux') { is $size, $actual_size, "actual size in bytes ok if sending in custom size"; } $k->clean_up_all; IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/PaxHeader/03-new.t000644 000765 000024 00000000210 15222763263 017647 xustar00stevestaff000000 000000 30 mtime=1783359155.486044273 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/03-new.t000644 000765 000024 00000004436 15222763263 015714 0ustar00stevestaff000000 000000 use warnings; use strict; use Data::Dumper; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw( assert_clean_process barrier_new barrier_release barrier_wait unique_glue require_free_sem_sets ); require_free_sem_sets(); use Test::SharedFork; my $mod = 'IPC::Shareable'; # A pipe barrier (see IPCShareableTest::barrier_new) replaces the old # SIGALRM/sleep handshake and its lost-wakeup race. my $ready = barrier_new(); # parent -> child: segments created # locking my $pid = fork; defined $pid or die "Cannot fork: $!\n"; if ($pid == 0) { # child barrier_wait($ready); my $ch = $mod->new(key => unique_glue('hash2')); $ch->{child} = 'child'; my $ca = $mod->new(key => unique_glue('array2'), var => 'ARRAY'); $ca->[1] = 'child'; my $cs = $mod->new(key => unique_glue('scalar2'), var => 'SCALAR'); $$cs = 'child'; } else { # parent my $ph = $mod->new(key => unique_glue('hash2'), create => 1, destroy => 1); like tied(%$ph), qr/IPC::Shareable/, "new() tied hash is proper object ok"; like tied(%$ph)->can('seg_count'), qr/CODE/, "...and it can call its methods ok"; my $pa = $mod->new(key => unique_glue('array2'), create => 1, destroy => 1, var => 'ARRAY'); like tied(@$pa), qr/IPC::Shareable/, "new() tied array is proper object ok"; like tied(@$pa)->can('seg_count'), qr/CODE/, "...and it can call its methods ok"; my $ps = $mod->new(key => unique_glue('scalar2'), create => 1, destroy => 1, var => 'SCALAR'); like tied($$ps), qr/IPC::Shareable/, "new() tied scalar is proper object ok"; like tied($$ps)->can('seg_count'), qr/CODE/, "...and it can call its methods ok"; barrier_release($ready); waitpid($pid, 0); is $ph->{child}, 'child', 'child set the hash value ok'; is $pa->[1], 'child', 'child set the array value ok'; is $$ps, 'child', 'child set the scalar value ok'; $ph->{parent} = 'parent'; is $ph->{parent}, 'parent', 'parent set the hash value ok'; $pa->[0] = 'parent'; is $pa->[0], 'parent', 'parent set the array value ok'; $$ps = "parent"; is $$ps, 'parent', 'parent set the scalar value ok'; IPC::Shareable->clean_up_all; assert_clean_process(); done_testing(); } IPC-Shareable-1.19/t/26-ipcav.t000644 000765 000024 00000004272 15207607742 016232 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(unique_glue assert_clean); # A two-phase pipe handshake replaces the old SIGALRM/sleep handshake, which # had a lost-wakeup race: a signal delivered in the window after the "unless # $awake" check but before sleep() blocked the process forever (the CPAN # smoker SIGKILLed a hung run of this test). Blocking pipe reads cannot miss # the wakeup. Same idiom as t/19 and t/24. my $glue = unique_glue('foco'); pipe(my $ready_r, my $ready_w) or die "Cannot create pipe: $!"; # parent -> child pipe(my $done_r, my $done_w) or die "Cannot create pipe: $!"; # child -> parent my $pid = fork; defined $pid or die "Cannot fork: $!"; if ($pid == 0) { # child (producer): attach only after the parent has created and emptied # the segment, then push 1..10 under the lock close $ready_w; close $done_r; <$ready_r>; close $ready_r; my @av; my $ipch = tie @av, 'IPC::Shareable', $glue, { create => 1, exclusive => 0, mode => 0666, size => 1024 * 512, destroy => 0, serializer => 'storable', }; for my $i (1 .. 10) { $ipch->shlock; push @av, $i; $ipch->shunlock; } print $done_w "done\n"; close $done_w; exit; } # parent (consumer) close $ready_r; close $done_w; my @av; my $ipch = tie @av, 'IPC::Shareable', $glue, { create => 1, exclusive => 0, mode => 0666, size => 1024 * 512, destroy => 'yes', serializer => 'storable', }; @av = (); print $ready_w "go\n"; # segment now exists and is empty; child may push close $ready_w; <$done_r>; # block until the child has pushed all 10 elements close $done_r; my %seen; $ipch->shlock; while (@av) { my $line = shift @av; ++$seen{$line}; } $ipch->shunlock; waitpid($pid, 0); my $count = 0; for (1 .. 10) { is $seen{$_}, 1, "child set elem $count to $_ ok"; $count++; } IPC::Shareable->clean_up_all; IPC::Shareable::_end; assert_clean(unique_glue('foco')); done_testing(); IPC-Shareable-1.19/t/90-pod_coverage.t000644 000765 000024 00000002053 15206611715 017553 0ustar00stevestaff000000 000000 use warnings; use strict; use Test::More; unless ( $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author test: RELEASE_TESTING not set" ); } # Ensure a recent version of Test::Pod::Coverage my $min_tpc = 1.08; eval "use Test::Pod::Coverage $min_tpc"; plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; my $pc = Pod::Coverage->new( package => 'IPC::Shareable', pod_from => 'lib/IPC/Shareable.pm', private => [ qr/^shlock$/, qr/^shunlock$/, qr/[A-Z]/, qr/^_/, qr/^bootstrap$/ ], ); is $pc->coverage, 1, "IPC::Shareable pod coverage ok"; if ($pc->uncovered) { warn "IPC::Shareable uncovered:\n\t", join( ", ", $pc->uncovered ), "\n"; } my $pc_shm = Pod::Coverage->new( package => 'IPC::Shareable::SharedMem', pod_from => 'lib/IPC/Shareable/SharedMem.pm', private => [qr/^_/], ); is $pc_shm->coverage, 1, "IPC::Shareable::SharedMem pod coverage ok"; if ($pc_shm->uncovered) { warn "IPC::Shareable::SharedMem uncovered:\n\t", join( ", ", $pc_shm->uncovered ), "\n"; } done_testing; IPC-Shareable-1.19/t/PaxHeader/75-is_child_xs.t000644 000765 000024 00000000207 15222763263 021365 xustar00stevestaff000000 000000 29 mtime=1783359155.48814669 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/75-is_child_xs.t000644 000765 000024 00000012713 15222763263 017421 0ustar00stevestaff000000 000000 use warnings; use strict; use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process require_free_sem_sets); require_free_sem_sets(); use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); my $have_xs = $IPC::Shareable::_have_xs; note $have_xs ? "XS _is_child path is ENABLED" : "XS _is_child path is DISABLED — testing pure Perl only"; # ── XS function existence ──────────────────────────────────────────────── SKIP: { skip 'XS not compiled on this system', 1 unless $have_xs; ok defined(&IPC::Shareable::_is_child_xs), 'XS _is_child_xs function is defined'; } # ── Untied refs: both paths return undef ───────────────────────────────── { local $IPC::Shareable::_have_xs = 0; is IPC::Shareable::_is_child(undef), undef, 'PP: undef -> undef'; is IPC::Shareable::_is_child("string"), undef, 'PP: string -> undef'; is IPC::Shareable::_is_child(42), undef, 'PP: integer -> undef'; is IPC::Shareable::_is_child({}), undef, 'PP: untied hashref -> undef'; is IPC::Shareable::_is_child([]), undef, 'PP: untied arrayref -> undef'; is IPC::Shareable::_is_child(\my $x), undef, 'PP: untied scalarref -> undef'; is IPC::Shareable::_is_child(sub { 1 }), undef, 'PP: coderef -> undef'; } SKIP: { skip 'XS not available', 7 unless $have_xs; is IPC::Shareable::_is_child(undef), undef, 'XS: undef -> undef'; is IPC::Shareable::_is_child("string"), undef, 'XS: string -> undef'; is IPC::Shareable::_is_child(42), undef, 'XS: integer -> undef'; is IPC::Shareable::_is_child({}), undef, 'XS: untied hashref -> undef'; is IPC::Shareable::_is_child([]), undef, 'XS: untied arrayref -> undef'; is IPC::Shareable::_is_child(\my $y), undef, 'XS: untied scalarref -> undef'; is IPC::Shareable::_is_child(sub { 1 }), undef, 'XS: coderef -> undef'; } # ── Tied refs: test each type independently in its own scope ───────────── { my %h; my $knot_h = tie %h, 'IPC::Shareable', { create => 1, destroy => 1, serializer => 'storable' }; my $href = \%h; # PP path { local $IPC::Shareable::_have_xs = 0; my $r = IPC::Shareable::_is_child($href); isa_ok $r, 'IPC::Shareable', 'PP: tied hashref -> knot object'; is $r, $knot_h, 'PP: tied hashref returns the correct knot'; } # XS path SKIP: { skip 'XS not available', 2 unless $have_xs; my $r = IPC::Shareable::_is_child($href); isa_ok $r, 'IPC::Shareable', 'XS: tied hashref -> knot object'; is $r, $knot_h, 'XS: tied hashref returns the correct knot'; } IPC::Shareable->clean_up; } { my @a; my $knot_a = tie @a, 'IPC::Shareable', { create => 1, destroy => 1, serializer => 'storable' }; my $aref = \@a; { local $IPC::Shareable::_have_xs = 0; my $r = IPC::Shareable::_is_child($aref); isa_ok $r, 'IPC::Shareable', 'PP: tied arrayref -> knot object'; is $r, $knot_a, 'PP: tied arrayref returns the correct knot'; } SKIP: { skip 'XS not available', 2 unless $have_xs; my $r = IPC::Shareable::_is_child($aref); isa_ok $r, 'IPC::Shareable', 'XS: tied arrayref -> knot object'; is $r, $knot_a, 'XS: tied arrayref returns the correct knot'; } IPC::Shareable->clean_up; } { my $s; my $knot_s = tie $s, 'IPC::Shareable', { create => 1, destroy => 1, serializer => 'storable' }; my $sref = \$s; { local $IPC::Shareable::_have_xs = 0; my $r = IPC::Shareable::_is_child($sref); isa_ok $r, 'IPC::Shareable', 'PP: tied scalarref -> knot object'; is $r, $knot_s, 'PP: tied scalarref returns the correct knot'; } SKIP: { skip 'XS not available', 2 unless $have_xs; my $r = IPC::Shareable::_is_child($sref); isa_ok $r, 'IPC::Shareable', 'XS: tied scalarref -> knot object'; is $r, $knot_s, 'XS: tied scalarref returns the correct knot'; } IPC::Shareable->clean_up; } # ── Simulate no-compiler: test full tie/STORE/FETCH/lock/unlock under PP ─ { local $IPC::Shareable::_have_xs = 0; my %nc_h; my $nc_knot = tie %nc_h, 'IPC::Shareable', { create => 1, destroy => 1, serializer => 'storable' }; ok tied(%nc_h), 'no-compiler simulation: tie succeeds under pure Perl'; $nc_h{foo} = 'bar'; is $nc_h{foo}, 'bar', 'no-compiler simulation: FETCH works'; $nc_h{child} = { a => 1, b => 2 }; is_deeply $nc_h{child}, { a => 1, b => 2 }, 'no-compiler simulation: nested hash round-trips'; my $child_ref = IPC::Shareable::_is_child($nc_h{child}); isa_ok $child_ref, 'IPC::Shareable', 'no-compiler simulation: _is_child detects nested shareable'; tied(%nc_h)->lock; $nc_h{foo} = 'locked_write'; is $nc_h{foo}, 'locked_write', 'no-compiler simulation: locked write'; tied(%nc_h)->unlock; IPC::Shareable->clean_up; } # ── Cleanup ────────────────────────────────────────────────────────────── IPC::Shareable->clean_up_all; IPC::Shareable::_end; assert_clean_process(); done_testing; IPC-Shareable-1.19/t/PaxHeader/14-attributes.t000644 000765 000024 00000000210 15222763263 021246 xustar00stevestaff000000 000000 30 mtime=1783359155.486533731 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/14-attributes.t000644 000765 000024 00000006302 15222763263 017305 0ustar00stevestaff000000 000000 use warnings; use strict; use Data::Dumper; use IPC::Shareable; use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue require_free_sem_sets); require_free_sem_sets(); my $glue = unique_glue('testing'); my $k = tie my $sv, 'IPC::Shareable', $glue, {create => 1, destroy => 1, serializer => 'storable' }; my $attrs_tied = (tied $sv)->attributes; is ref $attrs_tied, 'HASH', "tied var attributes() returns a hash ref ok"; my $attrs = { %{ $k->attributes } }; $k->testing_set('IPC::Shareable'); is ref $attrs, 'HASH', "attributes() returns a hash ref ok"; my @attr_list = qw( warn exclusive key serializer size protected testing limit magic mode create owner graceful destroy enforced_write_locking enforced_read_locking violated_write_lock_warn violated_read_lock_warn ); is keys %$attrs, scalar @attr_list, "attributes() hash has proper count of keys"; for (@attr_list) { is $k->attributes($_), $attrs->{$_}, "attributes($_) returns proper value ok"; } is $attrs->{warn}, 0, "warn is set ok"; is $attrs->{exclusive}, 0, "exclusive is set ok"; is $attrs->{key}, $glue, "key is set ok"; is $attrs->{serializer},'storable', "serializer is set ok"; is $attrs->{size}, 65536, "size is set ok"; is $attrs->{protected}, 0, "protected is set ok"; is $attrs->{testing}, 0, "testing is set ok"; is $attrs->{limit}, 1, "limit is set ok"; is $attrs->{magic}, 0, "magic is set ok"; is $attrs->{mode}, 438, "mode is set ok"; is $attrs->{create}, 1, "create is set ok"; is $attrs->{owner}, $$, "owner is set ok"; is $attrs->{graceful}, 0, "graceful is set ok"; is $attrs->{enforced_write_locking}, 1, "enforced_write_locking is set ok"; is $attrs->{enforced_read_locking}, 1, "enforced_read_locking is set ok"; is $attrs->{violated_write_lock_warn}, 1, "violated_write_lock_warn is set ok"; is $attrs->{violated_read_lock_warn}, 1, "violated_read_lock_warn is set ok"; is $k->attributes('no_exist'), undef, "attributes() on an undefined attr is undef"; # _parse_args: 'no' is a deprecated option value -- silently coerced to 0 { my $k2 = tie my $sv2, 'IPC::Shareable', { create => 'no', destroy => 1, serializer => 'storable', }; is $k2->attributes('create'), 0, "_parse_args: 'no' value coerced to 0 (no warnings flag)"; } # _parse_args: 'no' with $^W true emits a carp warning { my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_ }; my $k3; { local $^W = 1; $k3 = tie my $sv3, 'IPC::Shareable', { create => 'no', destroy => 1, serializer => 'storable', }; } is $k3->attributes('create'), 0, "_parse_args: 'no' with \$^W=1 still coerces to 0"; ok scalar(grep { /obsolete/ } @warnings), "_parse_args: 'no' with \$^W=1 emits obsolete-usage warning"; } # Default serializer should now be 'json' { my $kd = tie my $sv_def, 'IPC::Shareable', { create => 1, destroy => 1 }; is $kd->attributes('serializer'), 'json', "default serializer is 'json'"; } IPC::Shareable::_end; assert_clean_process(); done_testing; IPC-Shareable-1.19/t/21-lock_coderef.t000644 000765 000024 00000007011 15207655146 017535 0ustar00stevestaff000000 000000 use strict; use warnings; use Data::Dumper; use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue); use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use constant { LOCK_SH => 1, LOCK_EX => 2, LOCK_NB => 4, }; my $mod = 'IPC::Shareable'; my $knot = tie my %hv, $mod, { create => 1, key => unique_glue('k1234'), destroy => 1, }; # Only cref param { my $x = 0; my $ret = $knot->lock(sub { $x+=5; }); is $x, 5, "lock() with only a cref param works properly"; is $ret, 1, "...and return value is ok"; is $knot->{_lock}, 0, "...and knot is unlocked"; } # Both params (LOCK_EX) { my $x = 0; my $ret = $knot->lock(LOCK_EX, sub { $x+=10; }); is $x, 10, "lock() with LOCK_EX, and cref param works properly"; is $ret, 1, "...and return value is ok"; is $knot->{_lock}, 0, "...and knot is unlocked"; } # Both params (LOCK_NB) { my $x = 0; my $ret = $knot->lock(LOCK_SH|LOCK_NB, sub { $x+=10; }); is $x, 0, "lock() with LOCK_NB, and cref don't run cref ok"; is $ret, 1, "...and return value is ok"; is $knot->{_lock}, LOCK_SH|LOCK_NB, "...and knot remained locked"; $knot->unlock; is $knot->{_lock}, 0, "...and knot is unlocked after running unlock()"; } # Non-coderef passed as $code param: must croak { eval { $knot->lock(LOCK_EX, 'not_a_coderef') }; like $@, qr/must be a code ref/, "lock() croaks when non-coderef passed as \$code"; $knot->unlock if $knot->{_lock}; } # Coderef that throws: lock() re-throws and knot is unlocked { eval { $knot->lock(LOCK_EX, sub { die "boom\n" }) }; is $@, "boom\n", "lock() re-throws exception from coderef"; is $knot->{_lock}, 0, "...and knot is unlocked after coderef die"; } # Already holding a lock, call lock() again with same flags + coderef { # LOCK_EX { $knot->lock(LOCK_EX); is $knot->{_lock}, LOCK_EX, "knot is locked LOCK_EX"; my $x = 0; my $ret = $knot->lock(LOCK_EX, sub { $x = 7 }); is $x, 7, "coderef executes when re-locking with same LOCK_EX flags"; is $ret, 1, "...and return value is ok"; is $knot->{_lock}, 0, "...and auto-unlocked after coderef completes"; is $knot->unlock, 1, "...and unlock on already-unlocked knot is a no-op"; } # LOCK_SH { $knot->lock(LOCK_SH); is $knot->{_lock}, LOCK_SH, "knot is locked LOCK_SH"; my $x = 0; my $ret = $knot->lock(LOCK_SH, sub { $x = 9 }); is $x, 0, "coderef does not execute for non-LOCK_EX re-lock"; is $ret, 1, "...and return value is ok"; is $knot->{_lock}, LOCK_SH, "...and caller's original LOCK_SH is still held"; $knot->unlock; is $knot->{_lock}, 0, "...and knot is unlocked after manual unlock"; } # LOCK_EX | LOCK_NB { $knot->lock(LOCK_EX | LOCK_NB); is $knot->{_lock}, LOCK_EX | LOCK_NB, "knot is locked LOCK_EX|LOCK_NB"; my $x = 0; my $ret = $knot->lock(LOCK_EX | LOCK_NB, sub { $x = 3 }); is $x, 0, "coderef does not execute for non-LOCK_EX re-lock"; is $ret, 1, "...and return value is ok"; is $knot->{_lock}, LOCK_EX | LOCK_NB, "...and caller's original LOCK_EX|LOCK_NB is still held"; $knot->unlock; is $knot->{_lock}, 0, "...and knot is unlocked after manual unlock"; } } IPC::Shareable->clean_up_all; is %hv, '', "hash deleted after clean_up()"; IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/40-tied.t000644 000765 000024 00000000742 15207650136 016042 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process); tie my %hv, 'IPC::Shareable', {destroy => 1, serializer => 'storable' }; $hv{a} = 'foo'; is $hv{a}, 'foo', "data created and set ok"; tied(%hv)->clean_up; is %hv, '', "data is removed after tied(\$data)->clean_up()"; IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/61-json_fork_dup_rand_keys.t000644 000765 000024 00000003224 15207655146 022025 0ustar00stevestaff000000 000000 use warnings; use strict; # Test the fix to a bug where a random SHM key wasn't being created inside # of a fork() # It also regression tests a fix in global_register() where writing to the same # hash from two procs didn't update the global_register properly use IPC::Shareable qw(:lock); IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use Test::SharedFork; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue); BEGIN { if (! $ENV{ASYNC_TESTING}) { plan skip_all => "Developer only test... needs Async::Event::Interval"; } } use Async::Event::Interval; { tie my %shared_data, 'IPC::Shareable', { key => unique_glue('fork rand dup keys'), create => 1, serializer => 'json', destroy => 1 }; my $event_one = Async::Event::Interval->new(0, sub { tied(%shared_data)->lock; $shared_data{$$}{called}++; tied(%shared_data)->unlock; }); my $event_two = Async::Event::Interval->new(0, sub { tied(%shared_data)->lock; $shared_data{$$}{called}++; tied(%shared_data)->unlock; }); $event_one->start; $event_two->start; sleep 1; $event_one->stop; $event_two->stop; my $one_pid = $event_one->pid; my $two_pid = $event_two->pid; is exists $shared_data{$one_pid}{called}, 1, "json: Event one got a rand shm key ok"; is exists $shared_data{$two_pid}{called}, 1, "json: Adding srand() ensures _shm_key_rand() gives out rand key in fork()"; IPC::Shareable::clean_up_all; } Async::Event::Interval::_end; IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/PaxHeader/68-encode_fail.t000644 000765 000024 00000000210 15222763263 021321 xustar00stevestaff000000 000000 30 mtime=1783359155.487732356 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/68-encode_fail.t000644 000765 000024 00000010045 15222763263 017357 0ustar00stevestaff000000 000000 use warnings; use strict; use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process require_free_sem_sets); require_free_sem_sets(); use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); { # STORE croaks when _encode() returns undef (no lock held) tie my $sv => 'IPC::Shareable', { create => 1, destroy => 1 , serializer => 'storable' }; { # Override _encode via local typeglob, not Mock::Sub: Mock::Sub 1.08 # (on some CPAN testers) returns the call args for return_value => undef, # so the croak-on-undef path never fired. Bare `return` = failure in any # context; no warnings 'redefine' is block-scoped so real redefines warn. no warnings 'redefine'; local *IPC::Shareable::_encode = sub { return }; is eval { $sv = 'foo'; 1 }, undef, "STORE croaks when _encode() returns undef"; like $@, qr/Could not write to shared memory/, "...and the error message is correct"; } } { # CLEAR croaks when _encode() returns undef (no lock held) my $s = tie my %hv => 'IPC::Shareable', { create => 1, destroy => 1 , serializer => 'storable' }; $hv{a} = 1; { # Override _encode via local typeglob, not Mock::Sub: Mock::Sub 1.08 # (on some CPAN testers) returns the call args for return_value => undef, # so the croak-on-undef path never fired. Bare `return` = failure in any # context; no warnings 'redefine' is block-scoped so real redefines warn. no warnings 'redefine'; local *IPC::Shareable::_encode = sub { return }; is eval { %hv = (); 1 }, undef, "CLEAR croaks when _encode() returns undef"; like $@, qr/Could not write to shared memory/, "...and the CLEAR error message is correct"; } } { # DELETE croaks when _encode() returns undef (no lock held) tie my %hv => 'IPC::Shareable', { create => 1, destroy => 1 , serializer => 'storable' }; $hv{a} = 1; { # Override _encode via local typeglob, not Mock::Sub: Mock::Sub 1.08 # (on some CPAN testers) returns the call args for return_value => undef, # so the croak-on-undef path never fired. Bare `return` = failure in any # context; no warnings 'redefine' is block-scoped so real redefines warn. no warnings 'redefine'; local *IPC::Shareable::_encode = sub { return }; is eval { delete $hv{a}; 1 }, undef, "DELETE croaks when _encode() returns undef"; like $@, qr/Could not write to shared memory/, "...and the DELETE error message is correct"; } } for my $op ( [ 'PUSH', sub { my $a = shift; push @$a, 'x' } ], [ 'POP', sub { my $a = shift; pop @$a } ], [ 'SHIFT', sub { my $a = shift; shift @$a } ], [ 'UNSHIFT', sub { my $a = shift; unshift @$a, 'x' } ], [ 'SPLICE', sub { my $a = shift; splice @$a, 0, 1 } ], [ 'STORESIZE', sub { my $a = shift; $#$a = 2 } ], ) { my ($name, $code) = @$op; tie my @av => 'IPC::Shareable', { create => 1, destroy => 1 , serializer => 'storable' }; @av = (1, 2, 3); { # Override _encode via local typeglob, not Mock::Sub: Mock::Sub 1.08 # (on some CPAN testers) returns the call args for return_value => undef, # so the croak-on-undef path never fired. Bare `return` = failure in any # context; no warnings 'redefine' is block-scoped so real redefines warn. no warnings 'redefine'; local *IPC::Shareable::_encode = sub { return }; is eval { $code->(\@av); 1 }, undef, "$name croaks when _encode() returns undef"; like $@, qr/Could not write to shared memory/, "...$name error message is correct"; } } IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/99-end.t000644 000765 000024 00000002421 15207667015 015701 0ustar00stevestaff000000 000000 use 5.006; use strict; use warnings; use IPC::Shareable; use Test::More; BEGIN { use_ok( 'IPC::Shareable' ) || print "Bail out!\n"; } IPC::Shareable->testing_set('IPC::Shareable'); # See t/00-base.t: the whole-suite global IPC count check is serial-only, so # skip it under a parallel harness (eg. a smoker with HARNESS_OPTIONS=jN). my $parallel = defined $ENV{HARNESS_OPTIONS} && $ENV{HARNESS_OPTIONS} =~ /(?:^|:)j[0-9]/; my %store; my $seg_ok = eval { tie %store, 'IPC::Shareable', {key => 'async_tests', destroy => 1, serializer => 'storable'}; 1; }; if ($seg_ok) { my $start_segs = $store{segs}; my $start_sems = $store{sems}; IPC::Shareable::clean_up_all; my $segs = IPC::Shareable::seg_count(); my $sems = IPC::Shareable::sem_count(); SKIP: { skip "whole-suite IPC count check is serial-only (parallel harness detected)", 2 if $parallel; is $segs, $start_segs, "All test segments cleaned up after test run"; is $sems, $start_sems, "All test semaphores cleaned up after test run"; } if ($ENV{PRINT_SEGS}) { warn "Started with $start_segs, ending with $segs\n"; } } else { diag "async_tests segment not found; t/00-base.t may not have run. Skipping count comparison."; } done_testing();IPC-Shareable-1.19/t/PaxHeader/10-sv.t000644 000765 000024 00000000210 15222763263 017504 xustar00stevestaff000000 000000 30 mtime=1783359155.486361815 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/10-sv.t000644 000765 000024 00000004541 15222763263 015546 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue require_free_sem_sets); require_free_sem_sets(); tie my $sv, 'IPC::Shareable', {destroy => 1, serializer => 'storable' }; $sv = 'foo'; is $sv, 'foo', "SCALAR created ok, and set to 'foo'"; # This is a regression test for the # bug fixed by using Scalar::Util::reftype # instead of looking for HASH, SCALAR, ARRAY # in the stringified version of the scalar. for my $mod (qw/HASH SCALAR ARRAY/){ # --- TIESCALAR my $sv; tie($sv, 'IPC::Shareable', { destroy => 'yes' , serializer => 'storable' }) or die ('this was not expected to die here'); $sv = $mod.'foo'; is $sv, $mod.'foo', "SCALAR regression store/fetch ok"; } # FETCH from a never-written scalar segment returns undef (empty segment path) { tie my $sv, 'IPC::Shareable', { key => unique_glue('sv10e'), create => 1, destroy => 1 , serializer => 'storable' }; is $sv, undef, "FETCH on never-written scalar returns undef ok"; } # STORE edge case: previous value was undef. The TYPE_SCALAR STORE branch # (Shareable.pm:189-196) assigns _data = \$val on every store, so after # storing undef _data is a scalar-ref whose target is undef. A subsequent # STORE then exercises the truthy-but-dereferences-to-undef branch in # _remove_child without exploding. { my $k = tie my $sv, 'IPC::Shareable', { key => unique_glue('sv10f'), create => 1, destroy => 1, serializer => 'storable' }; $sv = undef; is $sv, undef, "scalar tied var assigned undef ok"; # _data is now \$undef. Force STORE to re-enter so it sees that state. is ref($k->{_data}), 'SCALAR', "...and _data is a SCALAR ref (to an undef value)"; is ${ $k->{_data} }, undef, "...where the underlying value is undef"; # Store a fresh value over the \$undef — STORE must walk the # ref-to-undef branch of _remove_child without exploding. $sv = 'after_undef'; is $sv, 'after_undef', "STORE of plain scalar over previous \\\$undef succeeds"; # And store a ref over what's now a plain scalar (TYPE_SCALAR branch with a tied child). $sv = { nested => 1 }; is $sv->{nested}, 1, "STORE of hash ref over plain scalar succeeds"; } IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/49-exhaust_shm_slots.t000644 000765 000024 00000004140 15207655146 020704 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue); # Determine the shm segment limit for this platform. # On macOS, kern.sysv.shmseg gives a per-process limit (typically 32). # On Linux, kernel.shmmni is a system-wide limit (typically 4096). # We can only run this test if the limit is low enough to exhaust safely. my $limit; { if ($^O eq 'darwin') { my $out = `sysctl kern.sysv.shmseg 2>/dev/null`; $limit = ($out =~ /(\d+)/) ? $1 : undef; } elsif ($^O eq 'linux') { if (open my $fh, '<', '/proc/sys/kernel/shmmni') { chomp($limit = <$fh>); } } if (! defined $limit) { plan skip_all => "Cannot determine shm segment limit on this platform ($^O)"; } elsif ($limit > 500) { plan skip_all => "shm segment limit ($limit) is too high to exhaust safely in a test"; } } my $mod = 'IPC::Shareable'; my $knot = tie my %hv, $mod, { create => 1, key => unique_glue('k1234'), destroy => 1, size => 1_048_576, # large enough that kernel slot limit is hit first }; my $ok = eval { for my $i (1 .. $limit + 100) { # Each unique key creates one child segment. No delete, so segments # accumulate until the kernel shm slot limit is reached. $hv{$i} = {val => $i}; } 1; }; # Dump diagnostic info unconditionally so CI output tells us exactly what happened #{ # my $sysctl_all = `sysctl kern.sysv 2>/dev/null` || '(no kern.sysv output)'; # chomp $sysctl_all; # diag "OS: $^O"; # diag "shm limit used: $limit"; # diag "sysctl kern.sysv:\n$sysctl_all"; # diag "error from eval: " . ($@ ? $@ : '(none)'); #} is $limit > 0, 1, "Operating with seg limit $limit"; is $ok, undef, "If we try to use all available shm slots, we croak()"; like $@, qr/No space left on device|Cannot allocate memory/, "...and error is sane"; IPC::Shareable->clean_up_all; IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/19-lock_recursive.t000644 000765 000024 00000021252 15222764416 020145 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable qw(:lock); IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use Test::SharedFork; use Time::HiRes qw(time); use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(unique_glue assert_clean require_free_sem_sets); require_free_sem_sets(); # --- Test 1: LOCK_EX on root holds child semaphore (LOCK_NB returns 0) --- { my $root = tie my %h, 'IPC::Shareable', { key => unique_glue('LR191'), create => 1, destroy => 1, serializer => 'json', }; $h{a} = { x => 1 }; my $child = tied(%{ $h{a} }); pipe(my $r, my $w) or die "pipe1: $!"; pipe(my $r2, my $w2) or die "pipe2: $!"; my $pid = fork; defined $pid or die "fork: $!"; if ($pid == 0) { close $w; # child doesn't write to pipe1 close $r2; # child doesn't read from pipe2 <$r>; # wait for parent to hold LOCK_EX close $r; my $got = $child->lock(LOCK_EX | LOCK_NB); is $got, 0, "LOCK_EX on root: child LOCK_EX|LOCK_NB returns 0 while parent holds lock"; print $w2 "done\n"; close $w2; exit 0; } # Hold LOCK_EX until the child's NB probe has completed, rather than for a # fixed interval: on a loaded smoker the child can be descheduled past any # fixed hold window, at which point its NB attempt would succeed and the # assertion would fail (seen on CPAN testers). close $r; # parent doesn't read from pipe1 close $w2; # parent doesn't write to pipe2 $root->lock(LOCK_EX); print $w "ready\n"; close $w; <$r2>; close $r2; # wait for child probe done $root->unlock; waitpid($pid, 0); IPC::Shareable->clean_up_all; } # --- Test 2: child semaphore released after parent unlock --- { my $root = tie my %h, 'IPC::Shareable', { key => unique_glue('LR192'), create => 1, destroy => 1, serializer => 'json', }; $h{a} = { x => 1 }; my $child = tied(%{ $h{a} }); pipe(my $r, my $w) or die "pipe1: $!"; pipe(my $r2, my $w2) or die "pipe2: $!"; my $pid = fork; defined $pid or die "fork: $!"; if ($pid == 0) { close $w; # child doesn't write to pipe1 close $r2; # child doesn't read from pipe2 <$r>; # wait for parent to unlock close $r; my $got = $child->lock(LOCK_EX | LOCK_NB); is $got, 1, "child LOCK_EX|LOCK_NB succeeds after parent unlock"; $child->unlock if $got; print $w2 "done\n"; close $w2; exit 0; } close $r; # parent doesn't read from pipe1 close $w2; # parent doesn't write to pipe2 $root->lock(LOCK_EX); select(undef, undef, undef, 0.1); $root->unlock; print $w "go\n"; close $w; <$r2>; close $r2; # wait for child assertion waitpid($pid, 0); IPC::Shareable->clean_up_all; } # --- Test 3: LOCK_SH on root holds LOCK_SH on child (blocks writers, not readers) --- { my $root = tie my %h, 'IPC::Shareable', { key => unique_glue('LR193'), create => 1, destroy => 1, serializer => 'json', }; $h{a} = { x => 1 }; my $child = tied(%{ $h{a} }); pipe(my $r, my $w) or die "pipe1: $!"; pipe(my $r2, my $w2) or die "pipe2: $!"; my $pid = fork; defined $pid or die "fork: $!"; if ($pid == 0) { close $w; close $r2; <$r>; close $r; # LOCK_SH should succeed concurrently with parent's LOCK_SH my $sh_got = $child->lock(LOCK_SH | LOCK_NB); is $sh_got, 1, "LOCK_SH on root: child LOCK_SH|LOCK_NB succeeds (readers share)"; $child->unlock if $sh_got; # LOCK_EX must be blocked by parent's LOCK_SH my $ex_got = $child->lock(LOCK_EX | LOCK_NB); is $ex_got, 0, "LOCK_SH on root: child LOCK_EX|LOCK_NB blocked while parent holds LOCK_SH"; print $w2 "done\n"; close $w2; exit 0; } # Hold LOCK_SH until the child's probes are done (see Test 1) close $r; close $w2; $root->lock(LOCK_SH); print $w "ready\n"; close $w; <$r2>; close $r2; $root->unlock; waitpid($pid, 0); IPC::Shareable->clean_up_all; } # --- Test 4: child _was_changed flushed to shared memory on parent unlock --- { my $root = tie my %h, 'IPC::Shareable', { key => unique_glue('LR194'), create => 1, destroy => 1, serializer => 'json', }; $h{a} = { x => 1 }; my $child = tied(%{ $h{a} }); $root->lock(LOCK_EX); $h{a}{y} = 99; # STORE on child under parent's lock is $child->{_was_changed}, 1, "_was_changed set on child knot after STORE under parent LOCK_EX"; $root->unlock; is $child->{_was_changed}, 0, "_was_changed cleared on child after parent unlock"; is $h{a}{y}, 99, "child write-back visible via FETCH after parent unlock"; IPC::Shareable->clean_up_all; } # --- Test 5: 3-level deep nesting — all semaphores held --- { my $root = tie my %h, 'IPC::Shareable', { key => unique_glue('LR195'), create => 1, destroy => 1, serializer => 'json', }; $h{a} = { b => { c => 1 } }; my $a_knot = tied(%{ $h{a} }); my $b_knot = tied(%{ $h{a}{b} }); pipe(my $r, my $w) or die "pipe1: $!"; pipe(my $r2, my $w2) or die "pipe2: $!"; my $pid = fork; defined $pid or die "fork: $!"; if ($pid == 0) { close $w; close $r2; <$r>; close $r; my $a_got = $a_knot->lock(LOCK_EX | LOCK_NB); is $a_got, 0, "3-level: level-1 child LOCK_EX|LOCK_NB blocked"; my $b_got = $b_knot->lock(LOCK_EX | LOCK_NB); is $b_got, 0, "3-level: level-2 grandchild LOCK_EX|LOCK_NB blocked"; print $w2 "done\n"; close $w2; exit 0; } # Hold LOCK_EX until the child's probes are done (see Test 1); the fixed # 0.3s hold raced against child scheduling and failed on loaded smokers # (the FreeBSD 15 CPAN tester FAILs for 1.18 were exactly this test) close $r; close $w2; $root->lock(LOCK_EX); print $w "ready\n"; close $w; <$r2>; close $r2; $root->unlock; waitpid($pid, 0); IPC::Shareable->clean_up_all; } # --- Test 6: LOCK_NB rollback — grandchild pre-locked, root LOCK_NB returns 0 --- { my $root = tie my %h, 'IPC::Shareable', { key => unique_glue('LR196'), create => 1, destroy => 1, serializer => 'json', }; $h{a} = { b => { c => 1 } }; my $a_knot = tied(%{ $h{a} }); my $b_knot = tied(%{ $h{a}{b} }); pipe(my $r, my $w) or die "pipe1: $!"; pipe(my $r2, my $w2) or die "pipe2: $!"; my $pid = fork; defined $pid or die "fork: $!"; if ($pid == 0) { # Child holds LOCK_EX on the grandchild until the parent has finished # its NB probes (see Test 1 for why a fixed hold interval is a race) close $r; close $w2; $b_knot->lock(LOCK_EX); print $w "locked\n"; close $w; <$r2>; close $r2; # wait for parent probes done $b_knot->unlock; exit 0; } close $w; close $r2; <$r>; # grandchild is now locked by child process close $r; my $got = $root->lock(LOCK_EX | LOCK_NB); is $got, 0, "LOCK_NB rollback: root lock returns 0 when grandchild is locked"; is $root->{_lock}, 0, "LOCK_NB rollback: root _lock reset to 0"; is $a_knot->{_lock}, 0, "LOCK_NB rollback: level-1 child _lock reset to 0"; # Verify root's semaphore was also released (NB attempt should succeed now for root alone) my $root_nb = $root->lock(LOCK_EX | LOCK_NB); is $root_nb, 0, "LOCK_NB rollback: root semaphore released (still blocked by held grandchild)"; print $w2 "done\n"; close $w2; waitpid($pid, 0); # After child releases, full lock should now work my $final = $root->lock(LOCK_EX | LOCK_NB); is $final, 1, "LOCK_NB rollback: root lock succeeds once grandchild is free"; $root->unlock if $final; IPC::Shareable->clean_up_all; } # --- Test 7: _locked_children cleared after unlock --- { my $root = tie my %h, 'IPC::Shareable', { key => unique_glue('LR197'), create => 1, destroy => 1, serializer => 'json', }; $h{a} = { x => 1 }; $root->lock(LOCK_EX); is scalar(@{ $root->{_locked_children} // [] }), 1, "_locked_children populated during LOCK_EX"; $root->unlock; is scalar(@{ $root->{_locked_children} // [] }), 0, "_locked_children cleared after unlock"; IPC::Shareable->clean_up_all; } IPC::Shareable::_end; assert_clean(map { unique_glue($_) } qw(LR191 LR192 LR193 LR194 LR195 LR196 LR197)); done_testing; IPC-Shareable-1.19/t/20-lock_operation.t000644 000765 000024 00000041720 15222764514 020127 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use Data::Dumper; use IPC::Semaphore; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use IPC::SysV qw(IPC_CREAT); use Mock::Sub; use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process require_free_sem_sets unique_glue); use Test::SharedFork; # The shared guard replaces the old create-3-probe-sets check: it skips # cleanly via plan skip_all (the probe's done_testing()/exit path still ended # in a 255 exit on resource-starved smokers), and it does not consume any of # the few remaining semaphore sets just to probe them. require_free_sem_sets(); my $sv; #my $awake = 0; #local $SIG{ALRM} = sub { $awake = 1 }; # ## locking # #my $pid = fork; #defined $pid or die "Cannot fork: $!\n"; # #if ($pid == 0) { # # child # # sleep unless $awake; # tie($sv, 'IPC::Shareable', unique_glue('TEST'), { destroy => 0 , serializer => 'storable' }); # # for (0 .. 99) { # (tied $sv)->lock; # ++$sv; # (tied $sv)->unlock; # } # is $sv, 100, "in child: locked and set SV to 100"; # exit; # #} else { # # parent # # tie($sv, 'IPC::Shareable', unique_glue('TEST'), { create => 1, destroy => 1 , serializer => 'storable' }) # or die "parent process can't tie \$sv"; # $sv = 0; # kill ALRM => $pid; # waitpid($pid, 0); # for (0 .. 99) { # (tied $sv)->lock; # ++$sv; # (tied $sv)->unlock; # } # is $sv, 200, "in parent: locked and updated SV to 200"; #} # Advisory locking { my $k1 = tie my %h1, 'IPC::Shareable', { key => unique_glue('TEST1'), create => 1, destroy => 1, enforced_write_locking => 0, enforced_read_locking => 0, serializer => 'storable' }; my $k2 = tie my %h2, 'IPC::Shareable', { key => unique_glue('TEST1'), create => 1, destroy => 1, enforced_write_locking => 0, enforced_read_locking => 0, serializer => 'storable' }; $h1{a} = {b => 1}; is_deeply {%h1}, {a => {b => 1}}, "h1 - initial value set"; is_deeply {%h2}, {a => {b => 1}}, "h2 - sees h1's initial value via same key"; # Correct pattern for modifying nested data while locked: use a top-level # STORE on the parent hash, NOT $h1{a}->{b} = 3. # # Using a top-level STORE ($h1{a} = ...) sets _was_changed = 1 on k1 and # properly replaces the child segment via _magic_tie / _reset_segment. $k1->lock; $h1{a} = {b => 3}; # top-level STORE: sets k1->{_was_changed} = 1 $k1->unlock; # writes {a => {b => 3}} back to shared memory is_deeply {%h1}, {a => {b => 3}}, "h1 - locked STORE written back on unlock"; is_deeply {%h2}, {a => {b => 3}}, "h2 - sees h1's change after unlock"; # Without enforced_write_locking, a knot that does NOT call lock() bypasses the # semaphore and writes directly -- purely cooperative/advisory locking. $k1->lock; $h2{a} = {c => 10}; # k2 never locked: writes directly, no error $k1->unlock; #is_deeply {%h2}, {a => {b => 3}}, "h2 - back to pre-unlock of h1 data"; } # enforced_write_locking with warn defaulted on: write blocked AND warning fires { my $k1 = tie my %h1, 'IPC::Shareable', { key => unique_glue('TEST2'), create => 1, destroy => 1, enforced_write_locking => 1, enforced_read_locking => 1, serializer => 'storable', }; my $k2 = tie my %h2, 'IPC::Shareable', { key => unique_glue('TEST2'), enforced_write_locking => 1, enforced_read_locking => 1, serializer => 'storable', }; $h1{a} = 1; is $h1{a}, 1, "enforced_write_locking - initial value set"; $k1->lock; # k1 (the lock holder) can still write freely $h1{a} = 2; is $h1{a}, 2, "enforced_write_locking - lock holder can write while locked"; { local $SIG{__WARN__} = sub { my $w = shift; like $w, qr/exclusively locked/, "enforced_write_locking - blocked write warns 'exclusively locked'"; like $w, qr/${\$k2->uuid}/, "enforced_write_locking - warning contains k2 UUID"; like $w, qr/${\$k2->seg->id}/, "enforced_write_locking - warning contains segment ID"; }; $h2{a} = 99; } $k1->unlock; # after unlock, k2 can write freely again is $h2{a}, 2, "enforced_write_locking - after k1 unlock, h2 set properly"; $h2{a} = 3; is $h2{a}, 3, "enforced_write_locking - k2 can write after k1 unlocks"; } # enforced_write_locking with warn: k2 attempting a write while k1 holds LOCK_EX must croak { my $k1 = tie my %h1, 'IPC::Shareable', { key => unique_glue('TEST2'), create => 1, destroy => 1, enforced_write_locking => 1, enforced_read_locking => 1, serializer => 'storable', }; my $k2 = tie my %h2, 'IPC::Shareable', { key => unique_glue('TEST2'), enforced_write_locking => 1, enforced_read_locking => 1, violated_write_lock_warn => 1, violated_read_lock_warn => 1, serializer => 'storable', }; $h1{a} = 1; is $h1{a}, 1, "enforced_write_locking with warn - initial value set"; $k1->lock; # k1 (the lock holder) can still write freely $h1{a} = 2; is $h1{a}, 2, "enforced_write_locking with warn - lock holder can write while locked"; local $SIG{__WARN__} = sub { my $w = shift; my $uuid = $k2->uuid; my $seg_id = $k2->seg->id; like $w, qr/$uuid/, "With enforced_write_locking and violated_write_lock_warn, UUID in warning ok"; like $w, qr/$seg_id/, "With enforced_write_locking and violated_write_lock_warn, seg ID in warning ok"; }; $h2{a} = 99; $k1->unlock; # after unlock, k2 can write freely again is $h2{a}, 2, "enforced_write_locking with warn - after k1 unlock, h2 set properly"; $h2{a} = 3; is $h2{a}, 3, "enforced_write_locking with warn - k2 can write after k1 unlocks"; } # enforced_write_locking ON + violated_write_lock_warn OFF: write blocked but no warning { my $k1 = tie my %h1, 'IPC::Shareable', { key => unique_glue('TEST2A'), create => 1, destroy => 1, enforced_write_locking => 1, enforced_read_locking => 1, violated_write_lock_warn => 0, violated_read_lock_warn => 0, serializer => 'storable', }; my $k2 = tie my %h2, 'IPC::Shareable', { key => unique_glue('TEST2A'), enforced_write_locking => 1, enforced_read_locking => 1, violated_write_lock_warn => 0, violated_read_lock_warn => 0, serializer => 'storable', }; $h1{a} = 1; $k1->lock; my $warned = 0; { local $SIG{__WARN__} = sub { $warned++ }; $h2{a} = 99; # blocked silently } is $warned, 0, "EW=1 VW=0: blocked write does NOT emit warning"; $k1->unlock; is $h2{a}, 1, "EW=1 VW=0: write was indeed blocked while k1 held LOCK_EX"; $h2{a} = 3; is $h2{a}, 3, "EW=1 VW=0: k2 writes succeed after k1 unlocks"; } # enforced_write_locking OFF + violated_write_lock_warn OFF: no enforcement, no warnings (degenerate) { my $k1 = tie my %h1, 'IPC::Shareable', { key => unique_glue('TEST2B'), create => 1, destroy => 1, enforced_write_locking => 0, enforced_read_locking => 0, violated_write_lock_warn => 0, violated_read_lock_warn => 0, serializer => 'storable', }; my $k2 = tie my %h2, 'IPC::Shareable', { key => unique_glue('TEST2B'), enforced_write_locking => 0, enforced_read_locking => 0, violated_write_lock_warn => 0, violated_read_lock_warn => 0, serializer => 'storable', }; $h1{a} = 1; $k1->lock; my $warned = 0; { local $SIG{__WARN__} = sub { $warned++ }; $h2{a} = 99; my $v = $h2{a}; } is $warned, 0, "EW=0 VW=0: no warnings on write or read with all enforcement off"; $k1->unlock; is $h2{a}, 99, "EW=0 VW=0: k2 write succeeded (no enforcement)"; } # LOCK_EX + CLEAR on a hash: _was_changed deferred write { my $k = tie my %h, 'IPC::Shareable', { key => unique_glue('T3'), create => 1, destroy => 1 , serializer => 'storable' }; $h{a} = 1; $h{b} = 2; $k->lock(IPC::Shareable::LOCK_EX); %h = (); is $k->{_was_changed}, 1, "LOCK_EX CLEAR: _was_changed set while locked"; $k->unlock; is keys(%h), 0, "LOCK_EX CLEAR: hash empty after unlock"; } # LOCK_EX + DELETE on a hash: _was_changed deferred write { my $k = tie my %h, 'IPC::Shareable', { key => unique_glue('T4'), create => 1, destroy => 1 , serializer => 'storable' }; $h{x} = 10; $h{y} = 20; $k->lock(IPC::Shareable::LOCK_EX); delete $h{x}; is $k->{_was_changed}, 1, "LOCK_EX DELETE: _was_changed set while locked"; $k->unlock; is exists($h{x}), '', "LOCK_EX DELETE: key removed after unlock"; is $h{y}, 20, "LOCK_EX DELETE: other key intact after unlock"; } # LOCK_EX + array mutation ops: PUSH, POP, SHIFT, UNSHIFT, SPLICE { my $k = tie my @a, 'IPC::Shareable', { key => unique_glue('T5'), create => 1, destroy => 1 , serializer => 'storable' }; @a = (1, 2, 3); $k->lock(IPC::Shareable::LOCK_EX); push @a, 4; is $k->{_was_changed}, 1, "LOCK_EX PUSH: _was_changed set"; $k->{_was_changed} = 0; my $p = pop @a; is $p, 4, "LOCK_EX POP: returns correct value"; is $k->{_was_changed}, 1, "LOCK_EX POP: _was_changed set"; $k->{_was_changed} = 0; my $s = shift @a; is $s, 1, "LOCK_EX SHIFT: returns correct value"; is $k->{_was_changed}, 1, "LOCK_EX SHIFT: _was_changed set"; $k->{_was_changed} = 0; unshift @a, 9; is $k->{_was_changed}, 1, "LOCK_EX UNSHIFT: _was_changed set"; $k->{_was_changed} = 0; my @gone = splice @a, 0, 1, 99; is $gone[0], 9, "LOCK_EX SPLICE: spliced-out value correct"; is $k->{_was_changed}, 1, "LOCK_EX SPLICE: _was_changed set"; $k->unlock; is $a[0], 99, "LOCK_EX array ops: all changes written back on unlock"; } IPC::Shareable::_end; # flush cleanup to stay under OpenBSD semmni=10 # LOCK_SH: hash read ops skip _decode when already locked (EXISTS, FIRSTKEY) { my $k = tie my %h, 'IPC::Shareable', { key => unique_glue('T6'), create => 1, destroy => 1 , serializer => 'storable' }; $h{a} = 1; $k->lock(IPC::Shareable::LOCK_SH); ok exists($h{a}), "LOCK_SH EXISTS: returns true for existing key (uses cached _data)"; ok !exists($h{z}), "LOCK_SH EXISTS: returns false for missing key (uses cached _data)"; my @keys = keys %h; is scalar(@keys), 1, "LOCK_SH FIRSTKEY: keys() returns correct count while locked"; $k->unlock; } # LOCK_SH: array FETCHSIZE skips _decode when already locked { my $k = tie my @a, 'IPC::Shareable', { key => unique_glue('T7'), create => 1, destroy => 1, serializer => 'storable' }; @a = (1, 2, 3); $k->lock(IPC::Shareable::LOCK_SH); is scalar(@a), 3, "LOCK_SH FETCHSIZE: scalar(\@array) correct while locked (uses cached _data)"; $k->unlock; } # LOCK_EX + STORESIZE ($#array = N): _was_changed deferred write { my $k = tie my @a, 'IPC::Shareable', { key => unique_glue('T8'), create => 1, destroy => 1 , serializer => 'storable' }; @a = (1, 2, 3, 4, 5); $k->lock(IPC::Shareable::LOCK_EX); $#a = 1; is $k->{_was_changed}, 1, "LOCK_EX STORESIZE: _was_changed set while locked"; $k->unlock; is scalar(@a), 2, "LOCK_EX STORESIZE: array truncated after unlock"; } # enforced_write_locking: array write ops blocked when another knot holds LOCK_EX { my $k1 = tie my @a1, 'IPC::Shareable', { key => unique_glue('T9'), create => 1, destroy => 1, enforced_write_locking => 1, enforced_read_locking => 1, serializer => 'storable', }; my $k2 = tie my @a2, 'IPC::Shareable', { key => unique_glue('T9'), enforced_write_locking => 1, enforced_read_locking => 1, serializer => 'storable', }; @a1 = (1, 2, 3); $k1->lock(IPC::Shareable::LOCK_EX); my @lock_warns; local $SIG{__WARN__} = sub { push @lock_warns, shift }; push @a2, 99; is scalar(@a2), 3, "enforced_write_locking PUSH: blocked when k1 holds LOCK_EX"; pop @a2; is scalar(@a2), 3, "enforced_write_locking POP: blocked when k1 holds LOCK_EX"; shift @a2; is $a2[0], 1, "enforced_write_locking SHIFT: blocked when k1 holds LOCK_EX"; unshift @a2, 0; is $a2[0], 1, "enforced_write_locking UNSHIFT: blocked when k1 holds LOCK_EX"; splice @a2, 0, 1; is scalar(@a2), 3, "enforced_write_locking SPLICE: blocked when k1 holds LOCK_EX"; $#a2 = 0; is scalar(@a2), 3, "enforced_write_locking STORESIZE: blocked when k1 holds LOCK_EX"; $k1->unlock; is scalar(@lock_warns), 8, "enforced_write_locking array ops: one warning emitted per blocked write or unlocked read"; like $lock_warns[0], qr/exclusively locked/, "enforced_write_locking array ops: warning mentions 'exclusively locked'"; like $lock_warns[0], qr/${\$k2->uuid}/, "enforced_write_locking array ops: warning contains k2 UUID"; } IPC::Shareable::_end; # flush cleanup to stay under OpenBSD semmni=10 # enforced_write_locking: hash CLEAR and DELETE blocked when another knot holds LOCK_EX { my $k1 = tie my %h1, 'IPC::Shareable', { key => unique_glue('TA'), create => 1, destroy => 1, enforced_write_locking => 1, enforced_read_locking => 1, serializer => 'storable', }; my $k2 = tie my %h2, 'IPC::Shareable', { key => unique_glue('TA'), enforced_write_locking => 1, enforced_read_locking => 1, serializer => 'storable', }; $h1{a} = 1; $h1{b} = 2; $k1->lock(IPC::Shareable::LOCK_EX); my @lock_warns; local $SIG{__WARN__} = sub { push @lock_warns, shift }; delete $h2{a}; ok exists($h2{a}), "enforced_write_locking DELETE: blocked when k1 holds LOCK_EX"; %h2 = (); is $h2{a}, 1, "enforced_write_locking CLEAR: blocked when k1 holds LOCK_EX"; $k1->unlock; is scalar(@lock_warns), 3, "enforced_write_locking hash ops: one warning per blocked write or unlocked read"; like $lock_warns[0], qr/exclusively locked/, "enforced_write_locking hash ops: warning mentions 'exclusively locked'"; like $lock_warns[0], qr/${\$k2->uuid}/, "enforced_write_locking hash ops: warning contains k2 UUID"; } # lock() re-throws exception from code-ref (covers: die $err if !$ok) { my $k = tie my %h, 'IPC::Shareable', { key => unique_glue('TB'), create => 1, destroy => 1 , serializer => 'storable' }; $h{a} = 1; is eval { $k->lock(IPC::Shareable::LOCK_EX, sub { die "intentional error\n" }); 1 }, undef, "lock() code-ref: re-throws exception from code-ref"; like $@, qr/intentional error/, "lock() code-ref: error message propagated correctly"; is $k->{_lock}, 0, "lock() code-ref: lock released after exception"; } # unlock() croaks when _encode fails with _was_changed set (covers: croak in unlock _encode block) { my $k = tie my %h, 'IPC::Shareable', { key => unique_glue('TC'), create => 1, destroy => 1 , serializer => 'storable' }; $h{a} = 1; $k->lock(IPC::Shareable::LOCK_EX); $h{a} = 2; # STORE sets _was_changed = 1 is $k->{_was_changed}, 1, "unlock _encode fail: _was_changed is set while locked"; { # Override _encode via local typeglob, not Mock::Sub: Mock::Sub 1.08 # (on some CPAN testers) returns the call args for return_value => undef, # so the croak-on-undef path never fired. Bare `return` = failure in any # context; no warnings 'redefine' is block-scoped so real redefines warn. no warnings 'redefine'; local *IPC::Shareable::_encode = sub { return }; is eval { $k->unlock; 1 }, undef, "unlock() croaks when _encode returns undef with _was_changed set"; like $@, qr/Could not write to shared memory/, "...and the error message is correct"; } # Restore clean state so destroy => 1 cleanup works $k->{_was_changed} = 0; $k->unlock; } # unlock() croaks when sem->op fails (covers: croak "Could not release semaphore lock") { my $k = tie my %h, 'IPC::Shareable', { key => unique_glue('TD'), create => 1, destroy => 1 , serializer => 'storable' }; $h{a} = 1; $k->lock(IPC::Shareable::LOCK_EX); $k->{_was_changed} = 0; # skip the _encode block { my $mock = Mock::Sub->new; my $op_mock = $mock->mock('IPC::Semaphore::op', return_value => 0); is eval { $k->unlock; 1 }, undef, "unlock() croaks when sem->op returns false"; like $@, qr/Could not release semaphore lock/, "...and the error message is correct"; } # Manually clear lock flag; semaphore is destroyed with destroy => 1 $k->{_lock} = 0; } IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/PaxHeader/67-storable_fallback.t000644 000765 000024 00000000210 15222763263 022522 xustar00stevestaff000000 000000 30 mtime=1783359155.487632065 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/67-storable_fallback.t000644 000765 000024 00000013013 15222763263 020556 0ustar00stevestaff000000 000000 use warnings; use strict; use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process require_free_sem_sets); require_free_sem_sets(); use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); # Tests for the Storable-to-JSON auto-detection fallback: # When a segment was written with serializer => 'storable' and is later # re-attached without an explicit serializer (i.e. using the json default), # IPC::Shareable should detect the mismatch, switch to storable for the # session, and emit a carp warning. # ----------------------------------------------------------------------- # Helper: capture warnings into an array # ----------------------------------------------------------------------- sub capture_warns (&) { my $code = shift; my @w; local $SIG{__WARN__} = sub { push @w, @_ }; $code->(); return @w; } # ----------------------------------------------------------------------- # 1. A scalar holding a plain value is stored verbatim regardless of the # configured serializer, so it reads back cross-serializer with NO # fallback. (The storable->json fallback below still applies to aggregate # ties and to legacy Storable-frozen scalar segments.) # ----------------------------------------------------------------------- { my $key = 'sf_sv'; tie my $sv, 'IPC::Shareable', { key => $key, create => 1, destroy => 1, serializer => 'storable' }; $sv = 'hello'; my @warns = capture_warns { tie my $sv2, 'IPC::Shareable', { key => $key, create => 0, destroy => 1 }; is $sv2, 'hello', 'scalar: plain value readable cross-serializer (verbatim)'; my $sv2_knot = tied $sv2; is $sv2_knot->attributes('serializer'), 'json', 'scalar: no fallback needed - serializer stays json'; }; ok ! scalar(grep { /Storable-encoded/ } @warns), 'scalar: no fallback warning for a verbatim plain scalar'; } # ----------------------------------------------------------------------- # 2. Hash written with storable, re-attached with json default # ----------------------------------------------------------------------- { my $key = 'sf_hv'; tie my %h, 'IPC::Shareable', { key => $key, create => 1, destroy => 1, serializer => 'storable' }; %h = (foo => 'bar', n => 42); my @warns = capture_warns { tie my %h2, 'IPC::Shareable', { key => $key, create => 0, destroy => 1 }; is $h2{foo}, 'bar', 'hash: string value readable after fallback'; is $h2{n}, 42, 'hash: numeric value readable after fallback'; my $h2_knot = tied %h2; is $h2_knot->attributes('serializer'), 'storable', 'hash: serializer switched to storable for session'; }; ok scalar(grep { /Storable-encoded/ } @warns), 'hash: carp warning emitted'; } # ----------------------------------------------------------------------- # 3. Warning text mentions the segment hex key # ----------------------------------------------------------------------- { my $key = 'sf_key'; tie my %h, 'IPC::Shareable', { key => $key, create => 1, destroy => 1, serializer => 'storable' }; $h{x} = 1; my @warns = capture_warns { tie my %h2, 'IPC::Shareable', { key => $key, create => 0, destroy => 1 }; }; ok scalar(grep { /0x[0-9a-f]+/ } @warns), 'warning text contains hex segment key'; } # ----------------------------------------------------------------------- # 4. No warning when serializer is explicitly set to storable # ----------------------------------------------------------------------- { my $key = 'sf_nowarn'; tie my %h, 'IPC::Shareable', { key => $key, create => 1, destroy => 1, serializer => 'storable' }; $h{y} = 2; my @warns = capture_warns { tie my %h2, 'IPC::Shareable', { key => $key, create => 0, destroy => 1, serializer => 'storable' }; is $h2{y}, 2, 'explicit storable: data still readable'; }; ok !scalar(grep { /Storable-encoded/ } @warns), 'no fallback warning when serializer explicitly set to storable'; } # ----------------------------------------------------------------------- # 4b. Carp message matches the documented format and serializer attribute # is mutated to 'storable' after fallback. # ----------------------------------------------------------------------- { my $key = 'sf_format'; tie my %h, 'IPC::Shareable', { key => $key, create => 1, destroy => 1, serializer => 'storable' }; $h{f} = 'g'; my $knot; my @warns = capture_warns { $knot = tie my %h2, 'IPC::Shareable', { key => $key, create => 0, destroy => 1 }; }; my $msg = join '', @warns; like $msg, qr/IPC::Shareable: segment 0x[0-9a-f]{8} contains Storable-encoded data; switching serializer to 'storable' for this session\. Re-create the segment to migrate it to JSON\./, 'carp message matches the full documented format'; is $knot->attributes('serializer'), 'storable', 'attributes(serializer) mutated to storable post-fallback'; } # ----------------------------------------------------------------------- # 5. No warning when segment was written and read with json # ----------------------------------------------------------------------- { my @warns = capture_warns { tie my %h, 'IPC::Shareable', { create => 1, destroy => 1, serializer => 'json' }; $h{z} = 3; is $h{z}, 3, 'json round-trip ok'; }; ok !scalar(grep { /Storable-encoded/ } @warns), 'no fallback warning for a json segment'; } IPC::Shareable::_end; assert_clean_process(); done_testing; IPC-Shareable-1.19/t/04-new_tied_obj.t000644 000765 000024 00000001104 15207655146 017544 0ustar00stevestaff000000 000000 use warnings; use strict; use Data::Dumper; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue); my $mod = 'IPC::Shareable'; my $ph = $mod->new( key => unique_glue('hash'), create => 1, destroy => 1 ); my $k = tied %$ph; is ref $k, 'IPC::Shareable', "tied() returns a proper IPC::Shareable object ok"; is exists $k->{attributes}, 1, "...and it has proper attributes ok"; IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/85-clean.t000644 000765 000024 00000017461 15211722440 016207 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use Data::Dumper; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use IPC::Shareable::SharedMem; use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw( assert_clean_process barrier_new barrier_release barrier_wait unique_glue ); use Test::SharedFork; sub shm_cleaned { # shmread fails with EINVAL when the segment has been removed my $id = shift; my $data = ''; shmread($id, $data, 0, 6); return $!{EINVAL} ? 1 : 0; } # create not sent in { my $ret = eval { my $s = tie(my $sv, 'IPC::Shareable', unique_glue('child_sv'), { destroy => 0 , serializer => 'storable' }); 1; }; is $ret, undef, "We croak if a key is specified, create is not called and no segment exists"; like $@, qr/ERROR: Could not acquire/, "...and error message is sane"; } # remove() (default IPC_PRIVATE) { my $s = tie my $sv, 'IPC::Shareable', { destroy => 0 , serializer => 'storable' }; $sv = 'foobar'; is $sv, 'foobar', "Default (IPC_PRIVATE) SV set and value is 'foobar'"; my $id = $s->seg->id; my $global = $s->global_register; my $process = $s->process_register; is keys %$global, 1, "Global register has one entry ok"; is keys %$process, 1, "Process register has one entry ok"; is exists $global->{$id}, 1, "ID $id exists in global register"; is exists $global->{$id}, 1, "ID $id exists in process register"; $s->remove; is shm_cleaned($id), 1, "Default (IPC_PRIVATE) seg id $id removed after remove() ok"; is keys %$global, 0, "Global register cleaned after remove()"; is keys %$process, 0, "Process register cleaned after remove()"; } # remove() { my $s = tie my $sv, 'IPC::Shareable', unique_glue('test'), { create => 1, destroy => 0 , serializer => 'storable' }; $sv = 'foobar'; is $sv, 'foobar', "SV set and value is 'foobar'"; my $id = $s->seg->id; my $global = $s->global_register; my $process = $s->process_register; is keys %$global, 1, "Global register has one entry ok"; is keys %$process, 1, "Process register has one entry ok"; is exists $global->{$id}, 1, "ID $id exists in global register"; is exists $global->{$id}, 1, "ID $id exists in process register"; $s->remove; is shm_cleaned($id), 1, "seg id $id removed after remove() ok"; is keys %$global, 0, "Global register cleaned after remove()"; is keys %$process, 0, "Process register cleaned after remove()"; } # clean_up() { my $s = tie my $sv, 'IPC::Shareable', unique_glue('test'), { create => 1, destroy => 0 , serializer => 'storable' }; $sv = 'foobar'; is $sv, 'foobar', "SV set and value is 'foobar'"; my $id = $s->seg->id; my $global = $s->global_register; my $process = $s->process_register; is keys %$global, 1, "Global register has one entry ok"; is keys %$process, 1, "Process register has one entry ok"; is exists $global->{$id}, 1, "ID $id exists in global register"; is exists $global->{$id}, 1, "ID $id exists in process register"; $s->clean_up; is shm_cleaned($id), 1, "seg id $id removed after clean_up() ok"; is keys %$global, 0, "Global register cleaned after clean_up()"; is keys %$process, 0, "Process register cleaned after clean_up()"; } # clean_up_all() { my $s = tie my $sv, 'IPC::Shareable', unique_glue('test'), { create => 1, destroy => 0 , serializer => 'storable' }; $sv = 'foobar'; is $sv, 'foobar', "SV set and value is 'foobar'"; my $id = $s->seg->id; my $global = $s->global_register; my $process = $s->process_register; is keys %$global, 1, "Global register has one entry ok"; is keys %$process, 1, "Process register has one entry ok"; is exists $global->{$id}, 1, "ID $id exists in global register"; is exists $global->{$id}, 1, "ID $id exists in process register"; $s->clean_up_all; is shm_cleaned($id), 1, "seg id $id removed after clean_up_all() ok"; is keys %$global, 0, "Global register cleaned after clean_up_all()"; is keys %$process, 0, "Process register cleaned after clean_up_all()"; } my ($z, $y, $x, $w); # parent/child { my $ready = barrier_new(); # parent -> child: segment created my $pid = fork; defined $pid or die "Cannot fork : $!"; if ($pid == 0) { # child barrier_wait($ready); my $s = tie(my $sv, 'IPC::Shareable', unique_glue('kids'), { destroy => 0 , serializer => 'storable' }); $sv = 'baz'; is $sv, 'baz', "SV initialized and set to 'baz' ok"; IPC::Shareable->clean_up; my $data = ''; my $id = $s->seg->id; shmread($id, $data, 0, length('IPC::Shareable')); is $data, 'IPC::Shareable', "Shared memory alive ok in child"; $s->clean_up; is shm_cleaned($id), 0, "after clean_up(), all is well ok in child, we don't clean up what isn't ours"; shmread($id, $data, 0, length('IPC::Shareable')); is $data, 'IPC::Shareable', "SV doesn't get wiped if in a different proc w/clean_up()"; exit; } else { # parent my $s = tie(my $sv, 'IPC::Shareable', unique_glue('kids'), { create => 1, destroy => 0 , serializer => 'storable' }); barrier_release($ready); my $id = $s->seg->id; waitpid($pid, 0); is shm_cleaned($id), 0, "ID $id was not cleaned up in the child"; is keys %{ $s->global_register }, 1, "Global register set before clean_up_all()"; is keys %{ $s->process_register }, 1, "Process register set before clean_up_all()"; IPC::Shareable->clean_up_all; is keys %{ $s->global_register }, 0, "Global register cleaned with clean_up_all()"; is keys %{ $s->process_register }, 0, "Process register cleaned with clean_up_all()"; } } IPC::Shareable::_end; assert_clean_process(); # remove($key) warns when shmget fails for a non-existent key { my $warnings = []; local $SIG{__WARN__} = sub { push @$warnings, @_ }; IPC::Shareable->remove('0x1B0BFFFE'); # key never created is scalar(@$warnings), 1, "remove(non-existent key): emits exactly one warning"; like $warnings->[0], qr/shmget failed/, "remove(non-existent key): warning mentions shmget failed"; } # remove() (object form) warns when sem->remove fails { # destroy => 0: the shm segment is already gone after $k->remove, so no # double-remove on scope exit. Save the semaphore before mocking so we can # clean it up manually after the block (mock prevents normal cleanup). my $k = tie my %h, 'IPC::Shareable', { key => unique_glue('TE'), create => 1, destroy => 0 , serializer => 'storable' }; $h{a} = 1; my $orphan_sem = $k->sem; my @seen_warnings; local $SIG{__WARN__} = sub { push @seen_warnings, @_ }; { # Override IPC::Semaphore::remove via local typeglob, not Mock::Sub: # Mock::Sub 1.08 (on some CPAN testers) returns the call args for # return_value => undef, so sem->remove looked like it succeeded and the # warn path never fired. Bare `return` = failure in any context; no # warnings 'redefine' is block-scoped so real redefines warn. no warnings 'redefine'; local *IPC::Semaphore::remove = sub { return }; $k->remove; } # Mock is now out of scope; remove the orphaned semaphore that the mock left behind. $orphan_sem->remove; # undef return from sem->remove also triggers two 'uninitialized value' # warnings (from != and ne comparisons), so filter to the one we care about. my @sem_warns = grep { /Couldn't remove semaphore set/ } @seen_warnings; is scalar(@sem_warns), 1, "remove() object form: emits a 'Couldn't remove semaphore set' warning when sem->remove fails"; like $sem_warns[0], qr/Couldn't remove semaphore set/, "remove() object form: warning message is correct"; } done_testing(); IPC-Shareable-1.19/t/28-ipchv.t000644 000765 000024 00000010541 15211722163 016225 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use Test::SharedFork; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw( assert_clean barrier_new barrier_release barrier_wait unique_glue ); # A pipe-based barrier handshake (see IPCShareableTest::barrier_new) replaces # the old SIGALRM/sleep handshake, which had a lost-wakeup race: a signal # delivered between the "unless $awake" check and sleep() was dropped and the # sleeper blocked forever (the FreeBSD smoker hang) or the two processes # desynced (the long-double Linux undef reads). Each section walks the child # and parent through three barriers: segment-ready (parent -> child), # child-wrote (child -> parent), and parent-wrote (parent -> child). Waiting on # child-wrote also replaces the old non-deterministic "sleep 1". # --- serializer: storable ------------------------------------------------- my $seg_ready = barrier_new(); # parent -> child: segment created my $child_wrote = barrier_new(); # child -> parent: child's keys written my $parent_wrote = barrier_new(); # parent -> child: parent's keys written my $pid = fork; defined $pid or die "Cannot fork: $!"; if ($pid == 0) { # child barrier_wait($seg_ready); my $ipch = tie my %hv, 'IPC::Shareable', unique_glue('test'), { create => 'yes', exclusive => 0, mode => 0644, destroy => 0, serializer => 'storable', }; for (qw(fee fie foe fum)) { $ipch->shlock(); $hv{$_} = $$; $ipch->shunlock(); } barrier_release($child_wrote); barrier_wait($parent_wrote); my $parent = getppid; $parent == 1 and die "Parent process has unexpectedly gone away"; } else { # parent my $ipch = tie my %hv, 'IPC::Shareable', unique_glue('test'), { create => 1, exclusive => 0, mode => 0666, size => 1024*512, destroy => 'yes', serializer => 'storable', }; %hv = (); barrier_release($seg_ready); barrier_wait($child_wrote); for (qw(eenie meenie minie moe)) { $ipch->shlock(); $hv{$_} = $$; $ipch->shunlock(); } barrier_release($parent_wrote); waitpid($pid, 0); for (qw(fee fie foe fum)) { is $hv{$_}, $pid, "storable: parent: HV $_ has val $pid"; } for (qw(eenie meenie minie moe)) { is $hv{$_}, $$, "storable: parent: HV $_ has val $$"; } } # --- serializer: json (parent only) --------------------------------------- if ($pid != 0) { my $seg_ready2 = barrier_new(); my $child_wrote2 = barrier_new(); my $parent_wrote2 = barrier_new(); my $pid2 = fork; defined $pid2 or die "Cannot fork: $!"; if ($pid2 == 0) { # child barrier_wait($seg_ready2); my $ipch2 = tie my %hv, 'IPC::Shareable', unique_glue('testj'), { create => 'yes', exclusive => 0, mode => 0644, destroy => 0, serializer => 'json', }; for (qw(fee fie foe fum)) { $ipch2->shlock(); $hv{$_} = $$; $ipch2->shunlock(); } barrier_release($child_wrote2); barrier_wait($parent_wrote2); my $parent = getppid; $parent == 1 and die "Parent process has unexpectedly gone away"; exit; } else { # parent my $ipch2 = tie my %hv, 'IPC::Shareable', unique_glue('testj'), { create => 1, exclusive => 0, mode => 0666, size => 1024*512, destroy => 'yes', serializer => 'json', }; %hv = (); barrier_release($seg_ready2); barrier_wait($child_wrote2); for (qw(eenie meenie minie moe)) { $ipch2->shlock(); $hv{$_} = $$; $ipch2->shunlock(); } barrier_release($parent_wrote2); waitpid($pid2, 0); for (qw(fee fie foe fum)) { is $hv{$_}, $pid2, "json: parent: HV $_ has val $pid2"; } for (qw(eenie meenie minie moe)) { is $hv{$_}, $$, "json: parent: HV $_ has val $$"; } } } IPC::Shareable::_end; if ($pid != 0) { assert_clean(unique_glue('test'), unique_glue('testj')); done_testing(); } IPC-Shareable-1.19/t/PaxHeader/78-scalar-verbatim-edge.t000644 000765 000024 00000000207 15222763263 023056 xustar00stevestaff000000 000000 29 mtime=1783359155.48834994 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/78-scalar-verbatim-edge.t000644 000765 000024 00000014455 15222763263 021117 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue relieve_ipc_pressure require_free_sem_sets); require_free_sem_sets(); use JSON qw(encode_json); use Storable qw(freeze); # Backward-compat, storable, and validation edges for the automatic verbatim # scalar storage. # # relieve_ipc_pressure() between blocks is a no-op on roomy hosts (so behaviour # there is unchanged) but releases each block's IPC on small-semmni hosts like # OpenBSD (semmni=10), so the accumulated ties never exhaust the system. # --------------------------------------------------------------------------- # 1. A legacy {"__sv__":...} scalar segment (no sentinel) still reads: the # verbatim peek finds no \x1e and falls through to the json unwrap. # --------------------------------------------------------------------------- { tie my $s, 'IPC::Shareable', { key => unique_glue('edge-legacy-sv'), create => 1, destroy => 1, size => 1024 }; # Hand-write a legacy json-wrapped scalar body (what an older release wrote). tied($s)->seg->shmwrite('IPC::Shareable' . encode_json({ '__sv__' => 'hello' })); is $s, 'hello', 'legacy {"__sv__":...} scalar segment still reads correctly'; } relieve_ipc_pressure(); # --------------------------------------------------------------------------- # 2. A string that LOOKS like the wrapper is stored verbatim, not unwrapped: # the sentinel keeps us from re-interpreting the caller's bytes. # --------------------------------------------------------------------------- { tie my $s, 'IPC::Shareable', { key => unique_glue('edge-literal-sv'), create => 1, destroy => 1, size => 1024 }; my $trap = '{"__sv__":"trap"}'; $s = $trap; is $s, $trap, 'a literal __sv__-shaped string round-trips verbatim (not unwrapped)'; my $bytes = tied($s)->seg->shmread; $bytes =~ s/\x00+$//; is $bytes, "IPC::Shareable\x1e" . $trap, '...stored verbatim with the sentinel'; } relieve_ipc_pressure(); # --------------------------------------------------------------------------- # 3. A legacy Storable-frozen scalar segment (first body byte 0x04, not the # \x1e sentinel) still triggers the storable->json fallback: warn + switch. # --------------------------------------------------------------------------- { my $key = unique_glue('edge-legacy-frozen'); tie my $seed, 'IPC::Shareable', { key => $key, create => 1, destroy => 1, serializer => 'storable', size => 1024 }; # Hand-write a legacy Storable-frozen scalar body (freeze of \$val). tied($seed)->seg->shmwrite('IPC::Shareable' . freeze(\'frozen-hello')); my @warns; { local $SIG{__WARN__} = sub { push @warns, @_ }; tie my $s2, 'IPC::Shareable', { key => $key, create => 0, size => 1024 }; # json default is $s2, 'frozen-hello', 'legacy frozen scalar readable via storable->json fallback'; is tied($s2)->attributes('serializer'), 'storable', 'serializer switched to storable for the session'; } ok scalar(grep { /Storable-encoded/ } @warns), 'fallback warning emitted for the frozen scalar'; } relieve_ipc_pressure(); # --------------------------------------------------------------------------- # 4. Serializer-agnostic: a storable scalar holding a plain value is verbatim; # holding a ref it takes the storable path, and both round-trip. # --------------------------------------------------------------------------- { tie my $sp, 'IPC::Shareable', { key => unique_glue('edge-stor-plain'), create => 1, destroy => 1, serializer => 'storable', size => 1024 }; $sp = 'plain-stor'; is $sp, 'plain-stor', 'storable scalar plain value round-trips'; my $b = tied($sp)->seg->shmread; $b =~ s/\x00+$//; is $b, "IPC::Shareable\x1eplain-stor", '...stored verbatim (serializer-agnostic)'; } relieve_ipc_pressure(); { tie my $sr, 'IPC::Shareable', { key => unique_glue('edge-stor-ref'), create => 1, destroy => 1, serializer => 'storable', size => 4096 }; $sr = { deep => [1, 2, 3] }; is $sr->{deep}[2], 3, 'storable scalar holding a ref round-trips'; my $b = tied($sr)->seg->shmread; $b =~ s/\x00+$//; unlike $b, qr/^IPC::Shareable\x1e/, '...and is NOT verbatim (ref takes the serializer path)'; } relieve_ipc_pressure(); # --------------------------------------------------------------------------- # 5. Aggregate ties are untouched by verbatim (always serialized). # --------------------------------------------------------------------------- { tie my %hj, 'IPC::Shareable', { key => unique_glue('edge-hash-json'), create => 1, destroy => 1, size => 4096 }; %hj = (a => 1, b => 'two'); is $hj{a}, 1, 'json hash round-trips (a)'; is $hj{b}, 'two', 'json hash round-trips (b)'; my $b = tied(%hj)->seg->shmread; $b =~ s/\x00+$//; unlike $b, qr/^IPC::Shareable\x1e/, '...json hash segment is not verbatim'; tie my @aj, 'IPC::Shareable', { key => unique_glue('edge-arr-json'), create => 1, destroy => 1, size => 4096 }; @aj = (10, 20, 30); is $aj[1], 20, 'json array round-trips'; tie my %hs, 'IPC::Shareable', { key => unique_glue('edge-hash-stor'), create => 1, destroy => 1, serializer => 'storable', size => 4096 }; %hs = (x => 'y'); is $hs{x}, 'y', 'storable hash round-trips'; my $bs = tied(%hs)->seg->shmread; $bs =~ s/\x00+$//; unlike $bs, qr/^IPC::Shareable\x1e/, '...storable hash segment is not verbatim'; } relieve_ipc_pressure(); # --------------------------------------------------------------------------- # 6. Only json and storable are accepted serializers ('raw' is not public). # --------------------------------------------------------------------------- { for my $bad (qw(raw bogus none)) { my $ok = eval { tie my $s, 'IPC::Shareable', { key => unique_glue("edge-bad-$bad"), create => 1, destroy => 1, serializer => $bad }; 1; }; ok ! $ok, "serializer => '$bad' is rejected"; } eval { tie my $s, 'IPC::Shareable', { key => unique_glue('edge-bad-msg'), create => 1, destroy => 1, serializer => 'raw' } }; like $@, qr/must be 'json' or 'storable'/, 'rejection message names the valid serializers'; } relieve_ipc_pressure(); IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/PaxHeader/44-nested_segs_overwrite.t000644 000765 000024 00000000210 15222763263 023474 xustar00stevestaff000000 000000 30 mtime=1783359155.487395231 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/44-nested_segs_overwrite.t000644 000765 000024 00000007376 15222763263 021547 0ustar00stevestaff000000 000000 use warnings; use strict; use Data::Dumper; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(unique_glue assert_clean live_seg_count require_free_sem_sets); require_free_sem_sets(); # Verify that overwriting a tied child value with a new reference removes # the old child segment (no leak for flat overwrites; nested children of # the overwritten value are a known limitation tracked by the count checks). # Recursively dereference tied IPC::Shareable refs into plain Perl structures # so we can run clean_up_all without destroying data we want to compare. sub untie_deep { my ($val) = @_; my $type = Scalar::Util::reftype($val) or return $val; if ($type eq 'HASH') { my %copy; for my $k (keys %$val) { $copy{$k} = untie_deep($val->{$k}); } return \%copy; } elsif ($type eq 'ARRAY') { return [ map { untie_deep($_) } @$val ]; } elsif ($type eq 'SCALAR') { return \ untie_deep($$val); } return $val; } my @test_data = ( [ 1, 2, 3, [ 26, [ 30, 31 ] ] ], ); my %test_data = ( a => { a => 1, b => 2, c => 3, d => { z => 26, y => { yy => 25 } }, }, ); for my $serializer ('storable', 'json') { subtest "$serializer: array nested overwrite" => sub { my $glue = unique_glue("nested_av_$serializer"); tie my @a, 'IPC::Shareable', { key => $glue, create => 1, destroy => 1, serializer => $serializer, }; my $initial = live_seg_count(); $a[0] = [3]; my $after_first = live_seg_count(); is $after_first, $initial + 1, "first child adds one segment"; $a[0] = [1, 2]; my $after_overwrite = live_seg_count(); is $after_overwrite, $after_first, "flat overwrite replaces, no leak"; $a[0] = [1, 2, 3]; is live_seg_count(), $after_first, "flat overwrite again, no leak"; $a[0] = [1, 2, 3, [26, [30, 31]]]; is live_seg_count(), $initial + 3, "nested overwrite adds only net-new children"; my $data = untie_deep([@a]); IPC::Shareable->clean_up_all; is_deeply $data, \@test_data, "data matches expected"; }; subtest "$serializer: hash nested overwrite" => sub { my $glue = unique_glue("nested_hv_$serializer"); tie my %h, 'IPC::Shareable', { key => $glue, create => 1, destroy => 1, serializer => $serializer, }; my $initial = live_seg_count(); $h{a} = {a => 1}; my $after_first = live_seg_count(); is $after_first, $initial + 1, "first child adds one segment"; $h{a} = {a => 1, b => 2}; is live_seg_count(), $after_first, "flat overwrite replaces, no leak"; $h{a} = {a => 1, b => 2, c => 3}; is live_seg_count(), $after_first, "flat overwrite again, no leak"; $h{a} = {a => 1, b => 2, c => 3, d => {z => 26}}; my $after_nested1 = live_seg_count(); is $after_nested1, $initial + 2, "one-level nested adds only net-new children"; $h{a} = {a => 1, b => 2, c => 3, d => {z => 26, y => {yy => 25}}}; my $after_nested2 = live_seg_count(); is $after_nested2, $initial + 4, "deeper nested adds only net-new children"; my $data = untie_deep({ %h }); IPC::Shareable->clean_up_all; is_deeply $data, \%test_data, "data matches expected"; }; } IPC::Shareable::_end; assert_clean( unique_glue('nested_av_storable'), unique_glue('nested_hv_storable'), unique_glue('nested_av_json'), unique_glue('nested_hv_json'), ); done_testing;IPC-Shareable-1.19/t/PaxHeader/77-scalar-verbatim.t000644 000765 000024 00000000210 15222763263 022145 xustar00stevestaff000000 000000 30 mtime=1783359155.488252773 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/77-scalar-verbatim.t000644 000765 000024 00000022300 15222763263 020200 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable qw(:lock); IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process live_seg_count unique_glue relieve_ipc_pressure require_free_sem_sets); require_free_sem_sets(); use JSON qw(encode_json decode_json); use POSIX (); # A scalar holding a plain (non-ref) value is stored verbatim and automatically # under the normal (default json) tie: no __sv__ wrapping, no escaping, one # segment. The caller owns encode/decode. A reference still fans out as before. # # relieve_ipc_pressure() between blocks is a no-op on roomy hosts (so behaviour # there is unchanged) but releases each block's IPC on small-semmni hosts like # OpenBSD (semmni=10), so the accumulated ties never exhaust the system. my $SIZE = 65536; # --------------------------------------------------------------------------- # Segment layout: a plain scalar is 'IPC::Shareable' + \x1e + the bytes, # NOT wrapped as {"__sv__":...}. # --------------------------------------------------------------------------- { tie my $s, 'IPC::Shareable', { key => unique_glue('sv-fmt'), create => 1, destroy => 1, size => $SIZE }; $s = q({"a":1}); my $bytes = (tied $s)->seg->shmread; $bytes =~ s/\x00+$//; is $bytes, "IPC::Shareable\x1e" . q({"a":1}), 'plain scalar stored verbatim (tag + \x1e + bytes)'; unlike $bytes, qr/__sv__/, '...no __sv__ escaping in the segment'; } relieve_ipc_pressure(); # --------------------------------------------------------------------------- # Pre-serialize a deep structure -> ONE segment; fetch verbatim; user decodes. # --------------------------------------------------------------------------- { my $struct = { name => 'widget', count => 3, tags => [qw(a b c)], meta => { deep => [1, 2, { x => 'y' }] }, }; my $blob = encode_json($struct); my $before = live_seg_count(); tie my $s, 'IPC::Shareable', { key => unique_glue('sv-struct'), create => 1, destroy => 1, size => $SIZE }; $s = $blob; is live_seg_count() - $before, 1, 'pre-serialized deep structure occupies exactly ONE segment'; is $s, $blob, 'scalar returns the pre-serialized bytes verbatim'; is_deeply decode_json($s), $struct, 'caller decodes the bytes back to the original structure'; } relieve_ipc_pressure(); # Contrast: a native nested tie of the same shape fans out to many segments. { my $before = live_seg_count(); tie my %h, 'IPC::Shareable', { key => unique_glue('sv-native'), create => 1, destroy => 1, size => $SIZE }; %h = (name => 'widget', meta => { deep => [1, 2, { x => 'y' }] }); cmp_ok live_seg_count() - $before, '>', 1, 'a native nested tie fans out (verbatim collapses to one)'; } relieve_ipc_pressure(); # --------------------------------------------------------------------------- # Plain strings, integers, floats round-trip (numbers come back as strings). # --------------------------------------------------------------------------- { tie my $s, 'IPC::Shareable', { key => unique_glue('sv-scalars'), create => 1, destroy => 1, size => 1024 }; $s = 'just a plain string'; is $s, 'just a plain string', 'plain (non-JSON) string round-trips verbatim'; $s = 42; is $s, 42, 'integer round-trips (string-equal)'; cmp_ok $s, '==', 42, 'integer round-trips (numerically equal)'; $s = -7; cmp_ok $s, '==', -7, 'negative integer ok'; $s = 3.14; cmp_ok $s, '==', 3.14, 'float round-trips numerically'; } relieve_ipc_pressure(); # undef is preserved (falls through to {"__sv__":null}, not verbatim). { tie my $s, 'IPC::Shareable', { key => unique_glue('sv-undef'), create => 1, destroy => 1, size => 256 }; $s = 'set'; $s = undef; ok ! defined $s, 'undef round-trips as undef (preserved via normal path)'; my $bytes = (tied $s)->seg->shmread; $bytes =~ s/\x00+$//; is $bytes, q(IPC::Shareable{"__sv__":null}), '...stored as {"__sv__":null}, not verbatim'; } relieve_ipc_pressure(); # Empty string is a defined ''. { tie my $s, 'IPC::Shareable', { key => unique_glue('sv-empty'), create => 1, destroy => 1, size => 256 }; $s = ''; ok defined $s, 'empty string is defined'; is $s, '', '...and equals the empty string'; } relieve_ipc_pressure(); # --------------------------------------------------------------------------- # A reference still fans out into child segment(s) (unchanged behavior). # --------------------------------------------------------------------------- { my $before = live_seg_count(); tie my $s, 'IPC::Shareable', { key => unique_glue('sv-ref'), create => 1, destroy => 1, size => $SIZE }; $s = { a => 1, b => [2, 3] }; cmp_ok live_seg_count() - $before, '>', 1, 'a scalar holding a ref fans out (not verbatim)'; is $s->{a}, 1, 'ref value readable'; is $s->{b}[1], 3, 'nested ref value readable'; } relieve_ipc_pressure(); # --------------------------------------------------------------------------- # Flip-flop: string -> ref -> string in the same scalar; child cleaned up. # --------------------------------------------------------------------------- { my $base = live_seg_count(); tie my $s, 'IPC::Shareable', { key => unique_glue('sv-flip'), create => 1, destroy => 1, size => $SIZE }; $s = 'plain'; is $s, 'plain', 'flip: string value'; is live_seg_count() - $base, 1, '...one segment (verbatim)'; $s = { k => 9 }; is $s->{k}, 9, 'flip: ref value'; cmp_ok live_seg_count() - $base, '>', 1, '...fans out to a child'; $s = 'again'; is $s, 'again', 'flip: back to a string value'; is live_seg_count() - $base, 1, '...child cleaned up, back to one segment'; } relieve_ipc_pressure(); # --------------------------------------------------------------------------- # Round-trip under shared and exclusive locks. # --------------------------------------------------------------------------- { my $blob = encode_json({ a => 1 }); tie my $s, 'IPC::Shareable', { key => unique_glue('sv-lock'), create => 1, destroy => 1, size => 1024 }; $s = $blob; my $obj = tied $s; $obj->lock(LOCK_SH); is $s, $blob, 'LOCK_SH FETCH returns verbatim bytes'; $obj->unlock; my $blob2 = encode_json({ a => 2 }); $obj->lock(LOCK_EX); $s = $blob2; $obj->unlock; is $s, $blob2, 'LOCK_EX write then read back ok'; } relieve_ipc_pressure(); # --------------------------------------------------------------------------- # Payload hazards: literal tag text, the \x1e sentinel byte, internal NULs. # --------------------------------------------------------------------------- { tie my $s, 'IPC::Shareable', { key => unique_glue('sv-haz'), create => 1, destroy => 1, size => 1024 }; my $tagtext = 'IPC::Shareable' . '{"looks":"tagged"}'; $s = $tagtext; is $s, $tagtext, 'payload beginning with the literal tag round-trips'; $s = "a\x1eb\x1ec"; is $s, "a\x1eb\x1ec", 'payload containing the \x1e sentinel byte round-trips'; $s = "a\x00b\x00c"; is $s, "a\x00b\x00c", 'internal NUL bytes preserved'; is length($s), 5, '...with correct length'; } relieve_ipc_pressure(); # UTF-8 octets (encode_json output) round-trip and decode back intact. { tie my $s, 'IPC::Shareable', { key => unique_glue('sv-utf8'), create => 1, destroy => 1, size => 1024 }; my $struct = { msg => "caf\x{e9}", snow => "\x{2603}" }; my $blob = encode_json($struct); $s = $blob; is $s, $blob, 'UTF-8 JSON octets stored verbatim'; is_deeply decode_json($s), $struct, 'UTF-8 payload decodes back intact'; } relieve_ipc_pressure(); # Size guard still applies (tag + sentinel + payload must fit). { my $size = 64; tie my $s, 'IPC::Shareable', { key => unique_glue('sv-size'), create => 1, destroy => 1, size => $size }; my $fits = 'x' x ($size - length('IPC::Shareable') - 1); # -1 for the \x1e sentinel $s = $fits; is $s, $fits, 'payload that fills the segment (minus tag+sentinel) fits'; my $over = 'x' x ($size - length('IPC::Shareable')); my $ok = eval { $s = $over; 1 }; ok ! $ok, 'oversize payload croaks'; like $@, qr/exceeds shared segment size/, '...with the size-exceeded message'; } relieve_ipc_pressure(); # --------------------------------------------------------------------------- # Cross-process: a producer stores, a separate process reads verbatim. # --------------------------------------------------------------------------- { my $glue = unique_glue('sv-xproc'); my $blob = encode_json({ shared => [4, 5, 6], who => 'parent' }); tie my $p, 'IPC::Shareable', { key => $glue, create => 1, destroy => 1, size => $SIZE }; $p = $blob; pipe(my $rd, my $wr) or die "pipe: $!"; my $pid = fork; defined $pid or die "fork: $!"; if ($pid == 0) { close $rd; tie my $c, 'IPC::Shareable', { key => $glue, create => 0, size => $SIZE }; my $msg = (defined $c && $c eq $blob) ? 'MATCH' : 'MISMATCH'; print {$wr} $msg; close $wr; POSIX::_exit(0); } close $wr; my $got = do { local $/; <$rd> }; close $rd; waitpid $pid, 0; is $got, 'MATCH', "consumer process reads the producer's bytes verbatim"; } relieve_ipc_pressure(); IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/PaxHeader/25-fetch_nested_lock.t000644 000765 000024 00000000210 15222763263 022525 xustar00stevestaff000000 000000 30 mtime=1783359155.487031273 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/25-fetch_nested_lock.t000644 000765 000024 00000002615 15222763263 020567 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable qw(:lock); IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue require_free_sem_sets); require_free_sem_sets(); # Regression: FETCH re-decoding inner child segments under LOCK_EX cascade # caused a self-deadlock. _lock_children set SEM_WRITERS=1 on the child's # semaphore, then FETCH called _decode_json_restore which tried LOCK_SH on # the same semaphore — blocking on a lock the same process holds. { tie my %top, 'IPC::Shareable', { key => unique_glue('TOP_FETCH_DEADLOCK'), create => 1, destroy => 1, }; $top{0} = {}; tie my $scalar, 'IPC::Shareable', { key => unique_glue('SCALAR_FETCH_DEADLOCK'), create => 1, destroy => 1, }; $scalar = 'hello'; $top{0}{shared}{key1} = \$scalar; my $knot = tied %top; local $SIG{ALRM} = sub { die "FETCH deadlocked\n" }; alarm 5; my $ok = eval { $knot->lock(LOCK_EX, sub { $top{0}; # FETCH triggers the regression path }); 1; }; alarm 0; ok $ok, "FETCH under LOCK_EX with nested separately-tied refs does not deadlock" or diag "eval error: $@"; IPC::Shareable->clean_up_all; } IPC::Shareable::_end; assert_clean_process(); done_testing();IPC-Shareable-1.19/t/36-ipcobj.t000644 000765 000024 00000004247 15211722317 016370 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw( assert_clean_process barrier_new barrier_release barrier_wait unique_glue ); my $t = 1; my $ok = 1; { package Dummy; sub new { my $d = { _first => undef, _second => undef, }; return bless $d => shift; } sub first { my $self = shift; $self->{_first} = shift if @_; return $self->{_first}; } sub second { my $self = shift; $self->{_second} = shift if @_; return $self->{_second}; } } # A pipe barrier (see IPCShareableTest::barrier_new) replaces the old # SIGALRM/sleep handshake and its lost-wakeup race. my $ready = barrier_new(); # parent -> child: segment created my $pid = fork; defined $pid or die "Cannot fork : $!"; if ($pid == 0) { # child barrier_wait($ready); tie my $d, 'IPC::Shareable', unique_glue('obj'), { destroy => 0 , serializer => 'storable' }; # is ref($d), 'Dummy', "child: shared var has object ok"; # is $d->first(), 'foobar', "child: shared obj first() returns ok"; # is $d->second(), 'barfoo', "child: shared obj second() returns ok"; # is $d->first('foo'), 'foo', "shared obj first() returns ok, again"; # is $d->second('bar'), 'bar', "shared obj second() returns ok, again"; $d->first('kid did'); $d->second('this'); exit; } else { # parent my $s = tie my $d, 'IPC::Shareable', unique_glue('obj'), { create => 1, destroy => 1 , serializer => 'storable' }; # my $id = $s->{_shm}->{_id}; $d = { }; $d->{_first} = 'foobar'; $d->{_second} = 'barfoo'; $d = Dummy->new; $d->first('foobar'); $d->second('barfoo'); barrier_release($ready); waitpid($pid, 0); is $d->first(), 'kid did', "parent: shared obj first() returns ok"; is $d->second(), 'this', "parent: shared obj second() returns ok"; IPC::Shareable->clean_up_all; is defined $d, '', "parent: after clean_up_all(), everything's gone"; } IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/PaxHeader/16-ref.t000644 000765 000024 00000000207 15222763263 017644 xustar00stevestaff000000 000000 29 mtime=1783359155.48660094 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/16-ref.t000644 000765 000024 00000013402 15222763263 015674 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use Data::Dumper; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue require_free_sem_sets); require_free_sem_sets(); # serializer: storable { # scalar ref tie my $sv, 'IPC::Shareable', { destroy => 1 , serializer => 'storable' }; my $ref = 'ref'; $sv = \$ref; is $$sv, $ref, "storable: SV can be assigned a reference to another scalar"; # array ref $sv = [ 0 .. 9 ]; is ref($sv), 'ARRAY', "storable: SV contains an aref ok"; for (0 .. 9) { is $sv->[$_], $_, "storable: SV aref elem $_ ok"; } # hash ref my %check; my @k = map { ('a' .. 'z')[int(rand(26))] } (0 .. 9); my @v = map { ('A' .. 'Z')[int(rand(26))] } (0 .. 9); @check{@k} = @v; $sv = { %check }; is ref($sv), 'HASH', "storable: SV contains an href ok"; while (my($k, $v) = each %check) { is $sv->{$k}, $v, "storable: SV href key $k contains value $v ok"; } # multiple refs tie my @av, 'IPC::Shareable'; $av[0] = { foo => 'bar', baz => 'bash' , serializer => 'storable' }; $av[1] = [ 0 .. 9 ]; is ref($av[0]), 'HASH', "storable: AV elem 0 is a hash"; is ref($av[1]), 'ARRAY', "storable: AV elem 1 is an array"; is $av[0]->{foo}, 'bar', "storable: AV->HV contains valid value in key 'foo'"; is $av[0]->{baz}, 'bash', "storable: AV->HV contains valid value in key 'baz'"; for (0 .. 9) { is $av[1]->[$_], $_, "storable: AV[1]->[$_] == $_ ok"; } tie my %hv, 'IPC::Shareable', { serializer => 'storable' }; for ('a' .. 'z') { $hv{lower}->{$_} = $_; $hv{upper}->{$_} = uc; } for ('a' .. 'z') { is $hv{lower}->{$_}, $_, "storable: HV{lower}{$_} set to $_ ok"; is $hv{upper}->{$_}, uc $_, "storable: HV{upper}{$_} set to uppercase $_ ok"; } IPC::Shareable->clean_up_all; # deeply nested tie $sv, 'IPC::Shareable', { serializer => 'storable', destroy => 1 }; $sv->{this}->{is}->{nested}->{deeply}->[0]->[1]->[2] = 'found'; is $sv->{this}->{is}->{nested}->{deeply}->[0]->[1]->[2], 'found', "storable: crazy deep nested struct ok"; IPC::Shareable->clean_up_all; } # serializer: json { # scalar ref tie my $sv, 'IPC::Shareable', { serializer => 'json', destroy => 1 }; my $ref = 'ref'; $sv = \$ref; is $$sv, $ref, "json: SV can be assigned a reference to another scalar"; # array ref $sv = [ 0 .. 9 ]; is ref($sv), 'ARRAY', "json: SV contains an aref ok"; for (0 .. 9) { is $sv->[$_], $_, "json: SV aref elem $_ ok"; } # hash ref my %check; my @k = ('a' .. 'j'); my @v = ('A' .. 'J'); @check{@k} = @v; $sv = { %check }; is ref($sv), 'HASH', "json: SV contains an href ok"; for my $k (@k) { is $sv->{$k}, $check{$k}, "json: SV href key $k ok"; } # multiple refs via array tie tie my @av, 'IPC::Shareable', { serializer => 'json', destroy => 1 }; $av[0] = { foo => 'bar', baz => 'bash' }; $av[1] = [ 0 .. 9 ]; is ref($av[0]), 'HASH', "json: AV elem 0 is a hash"; is ref($av[1]), 'ARRAY', "json: AV elem 1 is an array"; is $av[0]->{foo}, 'bar', "json: AV->HV contains valid value in key 'foo'"; is $av[0]->{baz}, 'bash', "json: AV->HV contains valid value in key 'baz'"; for (0 .. 9) { is $av[1]->[$_], $_, "json: AV[1]->[$_] == $_ ok"; } tie my %hv, 'IPC::Shareable', { serializer => 'json', destroy => 1 }; for ('a' .. 'z') { $hv{lower}->{$_} = $_; $hv{upper}->{$_} = uc; } for ('a' .. 'z') { is $hv{lower}->{$_}, $_, "json: HV{lower}{$_} set to $_ ok"; is $hv{upper}->{$_}, uc $_, "json: HV{upper}{$_} set to uppercase $_ ok"; } IPC::Shareable->clean_up_all; # deeply nested via hash tie tie my %dh, 'IPC::Shareable', { serializer => 'json', destroy => 1 }; $dh{this}{is}{nested}{deeply}[0][1][2] = 'found'; is $dh{this}{is}{nested}{deeply}[0][1][2], 'found', "json: crazy deep nested struct ok"; IPC::Shareable->clean_up_all; # scalar child segment: json scalar-tie holding a ref to a pre-tied child scalar. # Exercises _encode_json_prepare SCALAR/REF branch (writes __ics__ marker) and # _decode_json TYPE_SCALAR + __ics__ branch (reattaches child on decode). # The "cold re-attach" sub-test verifies _decode_json_resolve/_decode_json_reattach # work correctly when there is no prior _data cache (new tie to the same key). { tie my $sv, 'IPC::Shareable', { key => unique_glue('16svp'), serializer => 'json', create => 1, destroy => 0 }; tie my $child, 'IPC::Shareable', { key => unique_glue('16svc'), serializer => 'json', create => 1, destroy => 0 }; $child = 'hello'; $sv = \$child; is ref($sv), 'SCALAR', "json: scalar-tie can hold a ref to a child scalar segment"; is $$sv, 'hello', "json: child scalar value readable through parent ref"; $$sv = 'world'; is $$sv, 'world', "json: child scalar writable through parent ref"; # Cold re-attach: new tie to the same parent key, no prior _data cache. # _decode_json must reattach the child scalar segment from the __ics__ marker. tie my $sv2, 'IPC::Shareable', { key => unique_glue('16svp'), serializer => 'json', create => 0, destroy => 0 }; is ref($sv2), 'SCALAR', "json: cold re-attach of scalar child: parent holds scalar ref"; is $$sv2, 'world', "json: cold re-attach of scalar child: correct value via re-attached child"; IPC::Shareable->clean_up_all; } } IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/PaxHeader/06-key.t000644 000765 000024 00000000210 15222763263 017651 xustar00stevestaff000000 000000 30 mtime=1783359155.486252231 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/06-key.t000644 000765 000024 00000017652 15222763263 015722 0ustar00stevestaff000000 000000 use warnings; use strict; use Data::Dumper; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Mock::Sub; use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process require_free_sem_sets); require_free_sem_sets(); # deprecated string key param { my $k; my $ok = eval { $k = tie my $sv, 'IPC::Shareable', 'TEST', {create => 1, destroy => 1, serializer => 'storable' }; 1; }; is $ok, 1, "IPC::Shareable accepts old string way of sending in key"; is $k->attributes('key'), 'TEST', "...and the key is ok"; is $k->seg->key, 4008350648 - 0x80000000, "...and the converted seg key is ok"; is $@, '', "...and no error message was set"; } # shm key matches object key { tie my $sv, 'IPC::Shareable', 'TEST', {create => 1, destroy => 1, serializer => 'storable' }; is((tied $sv)->seg->key, (tied $sv)->seg->key, "Object key matches segment key ok"); } # three letter caps { my $k = tie my $sv, 'IPC::Shareable', {key => 'TES', create => 1, destroy => 1, serializer => 'storable' }; is $k->{attributes}{key}, 'TES', "attr key is TES ok"; is $k->seg->key, 3952665712 - 0x80000000, "three letter attr key is ok"; } # four letter caps { my $k = tie my $sv, 'IPC::Shareable', {key => 'TEST', create => 1, destroy => 1, serializer => 'storable' }; is $k->{attributes}{key}, 'TEST', "attr key is TEST ok"; is $k->seg->key, 4008350648 - 0x80000000, "four letter attr key is ok"; } # three letter lower case { my $k = tie my $sv, 'IPC::Shareable', {key => 'tes', create => 1, destroy => 1, serializer => 'storable' }; is $k->{attributes}{key}, 'tes', "3 letter lower case key is tes ok"; is $k->seg->key, 2101323514, "3 letter lower case attr key is ok"; } # six letter { my $k = tie my $sv, 'IPC::Shareable', {key => 'tested', create => 1, destroy => 1, serializer => 'storable' }; is $k->{attributes}{key}, 'tested', "six letter attr key is tested ok"; is $k->seg->key, 142926612, "six letter attr key is ok"; } # filenames { my %key_hash = ( 'test/this.pl' => 2780677640, 'test/this.plx' => 2191663991, 'test/that.pl' => 135968112, 'test/testing/this.pl' => 1718888502, ); for (keys %key_hash) { my $k = tie my $sv, 'IPC::Shareable', {key => $_, create => 1, destroy => 1, serializer => 'storable' }; is $k->attributes('key'), $_, "$_ as key is the proper attribute ok"; my $key = $k->seg->key; if ($key_hash{$_} > 0x80000000) { is $key_hash{$_} - 0x80000000 == $k->_shm_key($_), 1, "key > 0x80000000 with subtract matches _shm_key() ok"; $key_hash{$_} = $k->_shm_key($_); } is $key, $key_hash{$_}, "...and key $_ converted to '$key' ok"; $k->clean_up_all; } } # strings { my %key_hash = ( 'thisisatest' => 4221762593, 'Thisisntatest' => 447918523, 'This is a test' => 3229261618, 'This isnt a test' => 4266902788, ); for (keys %key_hash) { my $k = tie my $sv, 'IPC::Shareable', {key => $_, create => 1, destroy => 1, serializer => 'storable' }; my $attr_key = $k->attributes('key'); is $attr_key, $_, "'$_' as key is the proper attribute ok"; my $key = $k->seg->key; if ($key_hash{$_} > 0x80000000) { is $key_hash{$_} - 0x80000000 == $k->_shm_key($_), 1, "key > 0x80000000 with subtract matches _shm_key() ok"; $key_hash{$_} = $k->_shm_key($_); } is $key, $key_hash{$_}, "...and key '$_' converted to '$key' ok"; $k->clean_up_all; } } # integers { my %key_hash = ( 1 => 1, 11 => 11, 10 => 10, 1000 => 1000, 65535 => 65535, ); for (keys %key_hash) { my $k = tie my $sv, 'IPC::Shareable', {key => $_, create => 1, destroy => 1, serializer => 'storable' }; my $attr_key = $k->attributes('key'); is $attr_key, $_, "'$_' as key is the proper attribute ok"; my $key = $k->seg->key; is $key, $key_hash{$_}, "...and key '$_' converted to '$key' ok"; $k->clean_up_all; } # large integers are used as-is (no overflow correction) { my $k = tie my $sv, 'IPC::Shareable', {key => 3735928559, create => 1, destroy => 1, serializer => 'storable' }; is $k->seg->key, 3735928559, "large decimal integer key used as-is (no overflow correction) ok"; $k->clean_up_all; } } # hex keys { # Stringified hex keys: the bit pattern is used directly (no overflow # correction), so ipcs(1) will show exactly the hex value supplied. my %key_hash = ( '0x1234' => 0x1234, '0xDEAD' => 0xDEAD, '0xdeadbeef' => 0xdeadbeef, '0xDeAdBeEf' => 0xDeAdBeEf, ); for my $hex_key (sort keys %key_hash) { my $k = tie my $sv, 'IPC::Shareable', {key => $hex_key, create => 1, destroy => 1, serializer => 'storable' }; is $k->attributes('key'), $hex_key, "hex string key '$hex_key' stored as attribute ok"; is $k->seg->key, $key_hash{$hex_key}, "...and '$hex_key' maps to integer $key_hash{$hex_key} (no overflow correction) ok"; $k->clean_up_all; } # Case-insensitive: '0xDEADBEEF' and '0xdeadbeef' resolve to the same segment { tie my $a, 'IPC::Shareable', {key => '0xDEADBEEF', create => 1, destroy => 0, serializer => 'storable' }; tie my $b, 'IPC::Shareable', {key => '0xdeadbeef', create => 0, destroy => 1, serializer => 'storable' }; my $key_a = (tied $a)->seg->key; my $key_b = (tied $b)->seg->key; is $key_a, $key_b, "'0xDEADBEEF' and '0xdeadbeef' resolve to the same segment ok"; (tied $b)->clean_up_all; } # Bare Perl hex literal (0xDEADBEEF without quotes) compiles to the decimal # integer 3735928559. It takes the decimal-integer path and is also used # as-is, so it resolves to the same segment as the quoted '0xDEADBEEF'. { tie my $a, 'IPC::Shareable', {key => '0xDEADBEEF', create => 1, destroy => 0, serializer => 'storable' }; tie my $b, 'IPC::Shareable', {key => 0xDEADBEEF, create => 0, destroy => 1, serializer => 'storable' }; my $key_a = (tied $a)->seg->key; my $key_b = (tied $b)->seg->key; is $key_a, $key_b, "quoted '0xDEADBEEF' and bare 0xDEADBEEF resolve to the same segment ok"; (tied $b)->clean_up_all; } } # _shm_key() croaks when CRC32 returns MAX_KEY_INT_SIZE (post-subtraction key == 0) { my $k = tie my $sv, 'IPC::Shareable', { key => 'force_zero_collision', create => 1, destroy => 1, serializer => 'storable' }; my $m = Mock::Sub->new; my $crc_mock = $m->mock('IPC::Shareable::crc32'); $crc_mock->return_value(0x80000000); # MAX_KEY_INT_SIZE my $ok = eval { $k->_shm_key('any string here'); 1 }; is $ok, undef, "_shm_key() croaks when CRC32 produces a post-subtraction key of 0"; like $@, qr/key which equals 0\. This is a fatal error/, "...and the error message matches the documented format"; $crc_mock->unmock; IPC::Shareable->clean_up_all; } # _shm_key_rand() collisions (in _mg_tie()) { my $m = Mock::Sub->new; my $sub = $m->mock('IPC::Shareable::_shm_key_rand_int'); $sub->return_value(555555); my $no_collision = eval { tie my %h, 'IPC::Shareable', { key => 'rand key gen', create => 1, destroy => 1 , serializer => 'storable' }; $h{a} = 1; $h{b}{c} = 2; $h{b}{d}{e} = 5; IPC::Shareable::clean_up_all; 1; }; is $no_collision, undef, "_shm_key_rand() fails if it can't find an available shm slot"; like $@, qr/available key after 10 tries/, "...the error shows it attempted multiple times"; } IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/12-hv.t000644 000765 000024 00000012465 15207655146 015544 0ustar00stevestaff000000 000000 use strict; use warnings; use Data::Dumper; use Test::More; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process live_seg_count unique_glue); my $mod = 'IPC::Shareable'; # serializer: storable { my $knot = tie my %hv, $mod, { create => 1, key => unique_glue('k1234'), destroy => 1, # serializer => 'json', # persist => 1 }; my %check; my (@k, @v, %used); for (0 .. 9) { my $n; do { $n = int(rand(26)); } while (exists $used{$n}); $used{$n} ++; push @k, ('a' .. 'z')[$n]; push @v, ('A' .. 'Z')[$n]; } @check{@k} = @v; while (my ($k, $v) = each %check) { $hv{$k} = $v; } is keys(%hv), 10, "hv has proper number of keys"; while (my ($k, $v) = each %check) { is $hv{$k}, $v, "check hash $k matches hv val $v"; } # --- EXISTS $hv{there} = undef; is exists($hv{there}), 1, "exists() works ok"; is defined($hv{there}), '', "defined with undef val ok"; # --- DELETE $hv{there}->{here} = 'yes'; is $hv{there}->{here}, 'yes', "hv there is ok"; $hv{there}->{here} = 'no'; is $hv{there}->{here}, 'no', "hv there is ok again"; $hv{there} = 'yes'; is $hv{there}, 'yes', "hv there is ok"; is defined($hv{there}), 1, "defined with val ok"; $hv{there} = 'no'; is $hv{there}, 'no', "hv there is ok again"; delete $hv{there}; is exists($hv{there}), '', "delete removes hash key and value"; # --- DELETE a key whose value is a nested tied child segment # Exercises the $child->remove path in DELETE $hv{nested} = { inner => 42 }; is ref($hv{nested}), 'HASH', "nested child segment created ok"; is $hv{nested}{inner}, 42, "nested child segment value ok"; my $child_segs_before = live_seg_count(); delete $hv{nested}; my $child_segs_after = live_seg_count(); is exists($hv{nested}), '', "delete of child-segment key removes it ok"; is $child_segs_after, $child_segs_before - 1, "DELETE child: child segment removed from system ok"; # --- CLEAR a hash that contains a nested tied child segment # Exercises the $child->remove path in CLEAR $hv{keep} = 'plain'; $hv{nested} = { inner => 99 }; is $hv{nested}{inner}, 99, "nested child for CLEAR test set ok"; my $clear_segs_before = live_seg_count(); %hv = (); my $clear_segs_after = live_seg_count(); is keys(%hv), 0, "clearing a hash with child segments works ok"; is $clear_segs_after, $clear_segs_before - 1, "CLEAR: child segment removed from system ok"; IPC::Shareable->clean_up_all; is % hv, '', "hash deleted after clean_up()"; } # serializer: json { my $knot = tie my %hv, $mod, { create => 1, key => unique_glue('k1234'), destroy => 1, serializer => 'json', # persist => 1 }; my %check; my (@k, @v, %used); for (0 .. 9) { my $n; do { $n = int(rand(26)); } while (exists $used{$n}); $used{$n} ++; push @k, ('a' .. 'z')[$n]; push @v, ('A' .. 'Z')[$n]; } @check{@k} = @v; while (my ($k, $v) = each %check) { $hv{$k} = $v; } is keys(%hv), 10, "json: hv has proper number of keys"; while (my ($k, $v) = each %check) { is $hv{$k}, $v, "json: check hash $k matches hv val $v"; } # --- EXISTS $hv{there} = undef; is exists($hv{there}), 1, "json: exists() works ok"; is defined($hv{there}), '', "json: defined with undef val ok"; # --- DELETE $hv{there}->{here} = 'yes'; is $hv{there}->{here}, 'yes', "json: hv there is ok"; $hv{there}->{here} = 'no'; is $hv{there}->{here}, 'no', "json: hv there is ok again"; $hv{there} = 'yes'; is $hv{there}, 'yes', "json: hv there is ok"; is defined($hv{there}), 1, "json: defined with val ok"; $hv{there} = 'no'; is $hv{there}, 'no', "json: hv there is ok again"; delete $hv{there}; is exists($hv{there}), '', "json: delete removes hash key and value"; # --- DELETE a key whose value is a nested tied child segment $hv{nested} = { inner => 42 }; is ref($hv{nested}), 'HASH', "json: nested child segment created ok"; is $hv{nested}{inner}, 42, "json: nested child segment value ok"; my $child_segs_before = live_seg_count(); delete $hv{nested}; my $child_segs_after = live_seg_count(); is exists($hv{nested}), '', "json: delete of child-segment key removes it ok"; is $child_segs_after, $child_segs_before - 1, "json: DELETE child: child segment removed from system ok"; # --- CLEAR a hash that contains nested tied child segments $hv{keep} = 'plain'; $hv{nested} = { inner => 99 }; is $hv{nested}{inner}, 99, "json: nested child for CLEAR test set ok"; my $clear_segs_before = live_seg_count(); %hv = (); my $clear_segs_after = live_seg_count(); is keys(%hv), 0, "json: clearing a hash with child segments works ok"; is $clear_segs_after, $clear_segs_before - 1, "json: CLEAR: child segment removed from system ok"; IPC::Shareable->clean_up_all; is % hv, '', "hash deleted after clean_up()"; } IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/73-internal.t000644 000765 000024 00000005727 15207650136 016747 0ustar00stevestaff000000 000000 use warnings; use strict; use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process); use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); # _key_str_to_int: decimal integer string { my $result = IPC::Shareable::_key_str_to_int('454328512'); is $result, 454328512, "_key_str_to_int: decimal string returns its numeric value"; } # _key_str_to_int: plain text CRC path — CRC below MAX_KEY_INT_SIZE { my $result = IPC::Shareable::_key_str_to_int('bar'); # crc32=1996459178, under limit ok defined($result), "_key_str_to_int: text key 'bar' returns defined integer"; like "$result", qr/^\d+$/, "_key_str_to_int: 'bar' result is a non-negative integer"; } # _key_str_to_int: plain text CRC path — CRC above MAX_KEY_INT_SIZE { my $result = IPC::Shareable::_key_str_to_int('foo'); # crc32=2356372769, OVER limit ok defined($result), "_key_str_to_int: text key 'foo' (CRC > limit) returns defined integer"; like "$result", qr/^\d+$/, "_key_str_to_int: 'foo' result is a non-negative integer"; cmp_ok $result, '<', 0x80000000, "_key_str_to_int: 'foo' result was reduced below MAX_KEY_INT_SIZE"; } # _encode_json_prepare: fallthrough return for non-HASH/ARRAY/SCALAR/REF ref type. # We use a CODE ref here because its reftype is 'CODE' on every Perl version. # Regexp refs report reftype 'SCALAR' on 5.10.1 and 'Regexp' from 5.12 onwards, # which would steer this test through the SCALAR/REF branch on old Perls. { my $code = sub { 42 }; my $result = IPC::Shareable::_encode_json_prepare($code); is ref($result), 'CODE', "_encode_json_prepare: non-HASH/ARRAY/SCALAR/REF ref returned unchanged"; is $result->(), 42, "_encode_json_prepare: returned coderef is the same one passed in"; } # _decode_json: returns undef when segment data lacks the IPC::Shareable tag { package FakeSeg; sub new { bless { _d => $_[1] }, $_[0] } sub data { $_[0]->{_d} } package main; my $seg = FakeSeg->new("untagged content -- no IPC::Shareable prefix here"); my $result = IPC::Shareable::_decode_json($seg, undef); is $result, undef, "_decode_json: returns undef for untagged segment data"; } # _is_child: returns undef when the value is not tied to IPC::Shareable { my $plain = {}; # plain untied hashref my $result = IPC::Shareable::_is_child($plain); is $result, undef, "_is_child: returns undef for an untied hashref"; } # _magic_tie: croaks for an unsupported ref type { my $knot = tie my %h, 'IPC::Shareable', { create => 1, destroy => 1 , serializer => 'storable' }; my $code = sub { 42 }; # CODE ref — not HASH/ARRAY/SCALAR is eval { IPC::Shareable::_magic_tie($knot, $code, 'x'); 1 }, undef, "_magic_tie: croaks when value type is CODE"; like $@, qr/Variables of type CODE not implemented/, "_magic_tie: error message names the bad type"; } IPC::Shareable->clean_up_all; IPC::Shareable::_end; assert_clean_process(); done_testing; IPC-Shareable-1.19/t/54-singleton.t000644 000765 000024 00000001660 15207650136 017124 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process); # bad param my $ok = eval { IPC::Shareable->singleton(); 1 }; is $ok, undef, "singleton() croaks if no GLUE param sent in"; like $@, qr/GLUE parameter/, "...and error is sane"; # singleton no exit notice my ($proc, $warning); { local $SIG{__WARN__} = sub {$warning = shift;}; $proc = IPC::Shareable->singleton('LOCK'); is $proc, $$, "process ID $$ returned from singleton() ok on first call"; $proc = -1; is $proc, -1, "\$proc set to -1 ok"; $proc = IPC::Shareable->singleton('LOCK'); } END { is $proc, -1, "singleton() on second call doesn't return anything ok"; is $warning, undef, "singleton outputs no warnings by default"; IPC::Shareable::_end; assert_clean_process(); done_testing; }; IPC-Shareable-1.19/t/PaxHeader/60-exceptions.t000644 000765 000024 00000000210 15222763263 021242 xustar00stevestaff000000 000000 30 mtime=1783359155.487473898 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/60-exceptions.t000644 000765 000024 00000024017 15222763263 017304 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::SysV qw(IPC_RMID); use Mock::Sub; use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue require_free_sem_sets); require_free_sem_sets(); #plan skip_all => "TEST FILE NOT READY"; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); { # exclusive duplicate my $opts = { key => unique_glue('k1234'), create => 1, exclusive => 1, destroy => 1, mode => 0600, size => 999, serializer => 'storable', }; my $s = tie my %opt_test => 'IPC::Shareable', $opts; $opt_test{a} = 1; is eval { my $s = tie my %opt_test => 'IPC::Shareable', $opts; 1; }, undef, "trying to re-create an existing memory segment fails"; like $@, qr/using exclusive/, "...and error message is sane"; } IPC::Shareable::_end; assert_clean_process(); # _decode_json: croaks when decode_json returns undef (mocked) { tie my %h, 'IPC::Shareable', { create => 1, destroy => 1, serializer => 'json' }; $h{a} = 1; # write something so the segment has the IPC::Shareable tag # Use local typeglob override instead of Mock::Sub to avoid prototype mismatch # warnings (decode_json carries a ($) prototype). no warnings 'redefine' is # block-scoped so a genuine accidental redefine elsewhere still warns. no warnings 'redefine'; local *IPC::Shareable::decode_json = sub { return undef }; is eval { my $x = $h{a}; 1 }, undef, "_decode_json: croaks when decode_json returns undef"; like $@, qr/Munged shared memory segment/, "_decode_json: error message mentions munged segment"; } # _tie: limit check — croaks when size > SHMMAX_BYTES and limit => 1 { is eval { tie my %h, 'IPC::Shareable', { create => 1, destroy => 1, size => 2_000_000_000, limit => 1 , serializer => 'storable' }; 1 }, undef, "_tie limit: croaks when size exceeds SHMMAX_BYTES"; like $@, qr/larger than max size/, "_tie limit: error message mentions max size"; } # _tie: fallthrough croak when SharedMem->new returns undef (create => 1, not exclusive) { # Override SharedMem::new via local typeglob, not Mock::Sub: Mock::Sub 1.08 # (on some CPAN testers) returns the call args for return_value => undef, so # the croak-on-undef path never fired. Bare `return` = failure in any # context; no warnings 'redefine' is block-scoped so real redefines warn. no warnings 'redefine'; local *IPC::Shareable::SharedMem::new = sub { return }; is eval { tie my %h, 'IPC::Shareable', { create => 1, destroy => 1 , serializer => 'storable' }; 1 }, undef, "_tie: croaks when SharedMem->new returns undef"; like $@, qr/Could not create shared memory segment/, "_tie: error message mentions shared memory segment"; } # _tie: "Could not create semaphore set" when IPC::Semaphore->new returns undef { my $key = '0x1B0BFFF2'; my $key_int = hex($key); { # Override IPC::Semaphore::new via local typeglob, not Mock::Sub: # Mock::Sub 1.08 (on some CPAN testers) returns the call args for # return_value => undef, so the croak-on-undef path never fired. Bare # `return` = failure in any context; no warnings 'redefine' is # block-scoped so real redefines warn. no warnings 'redefine'; local *IPC::Semaphore::new = sub { return }; is eval { tie my %h, 'IPC::Shareable', { key => $key, create => 1, destroy => 0 , serializer => 'storable' }; 1 }, undef, "_tie: croaks when IPC::Semaphore->new returns undef"; like $@, qr/Could not create semaphore set/, "_tie: error message mentions semaphore set"; } # The segment was created before the semaphore set failed; _tie() now removes # it before croaking, so it is no longer orphaned. my $leaked_id = shmget($key_int, 0, 0); ok ! defined $leaked_id, "_tie: the just-created segment is removed, not orphaned, on sem-create failure"; shmctl($leaked_id, IPC_RMID, 0) if defined $leaked_id; # Safety net if it regresses } # _thaw: croaks when Storable::thaw returns undef (munged segment). # Uses an aggregate (hash) tie: a scalar holding a plain value is now stored # verbatim and never reaches _thaw, so the freeze/thaw path is exercised here. { tie my %h, 'IPC::Shareable', { create => 1, destroy => 1 , serializer => 'storable' }; %h = (k => 'hello'); # aggregate => Storable freeze (carries the tag) { # Override thaw via local typeglob, not Mock::Sub: Mock::Sub 1.08 (on # some CPAN testers) returns the call args for return_value => undef, so # the croak-on-undef path never fired. Bare `return` = failure in any # context; no warnings 'redefine' is block-scoped so real redefines warn. no warnings 'redefine'; local *IPC::Shareable::thaw = sub { return }; is eval { my $x = $h{k}; 1 }, undef, "_thaw: croaks when Storable::thaw returns undef"; like $@, qr/Munged shared memory segment/, "_thaw: error message mentions munged segment"; } } # _tie: croaks with OOM message when SharedMem->new fails with ENOMEM { # no warnings 'redefine' is block-scoped so a genuine accidental redefine # elsewhere still warns. no warnings 'redefine'; local *IPC::Shareable::SharedMem::new = sub { $! = 12; # ENOMEM return undef; }; is eval { tie my %h, 'IPC::Shareable', { create => 1, destroy => 1 , serializer => 'storable' }; 1 }, undef, "_tie: croaks when SharedMem->new fails with ENOMEM"; like $@, qr/spawning too many segments/, "_tie: OOM error message references segment spawning"; } # _tie: croaks when create+exclusive set but SharedMem->new returns undef # (SharedMem::new normally croaks itself for File exists; this tests the _tie fallthrough) { # no warnings 'redefine' is block-scoped so a genuine accidental redefine # elsewhere still warns. no warnings 'redefine'; local *IPC::Shareable::SharedMem::new = sub { $! = 17; # EEXIST return undef; }; is eval { tie my %h, 'IPC::Shareable', { create => 1, exclusive => 1, destroy => 1 , serializer => 'storable' }; 1 }, undef, "_tie: croaks when create+exclusive set and SharedMem->new returns undef"; like $@, qr/exclusive.*are set|Does the segment already exist/, "_tie: create+exclusive error message correct"; } # _tie: croaks when sem->op fails for the initial LOCK_SH { my $key = '0x1B0BFFF5'; my $key_int = hex($key); { my $mock = Mock::Sub->new; my $op_mock = $mock->mock('IPC::Semaphore::op', return_value => 0); is eval { tie my %h, 'IPC::Shareable', { key => $key, create => 1, destroy => 0 , serializer => 'storable' }; 1 }, undef, "_tie: croaks when sem->op fails for initial LOCK_SH"; like $@, qr/Could not obtain semaphore set lock/, "_tie: semaphore op failure error message correct"; } # SharedMem and the semaphore set were created before op failed — clean up manually. my $leaked_id = shmget($key_int, 0, 0); shmctl($leaked_id, IPC_RMID, 0) if defined $leaked_id; my $leaked_sem = IPC::Semaphore->new($key_int, 0, 0); $leaked_sem->remove if defined $leaked_sem; } # _tie: croaks when sem->setval fails during initialization { my $key = '0x1B0BFFF6'; my $key_int = hex($key); { my $mock = Mock::Sub->new; my $setval_mock = $mock->mock('IPC::Semaphore::setval', return_value => 0); is eval { tie my %h, 'IPC::Shareable', { key => $key, create => 1, destroy => 0 , serializer => 'storable' }; 1 }, undef, "_tie: croaks when sem->setval fails during initialization"; like $@, qr/Couldn't set semaphore during object creation/, "_tie: setval failure error message correct"; } # Clean up the leaked shm segment and semaphore set. my $leaked_id = shmget($key_int, 0, 0); shmctl($leaked_id, IPC_RMID, 0) if defined $leaked_id; my $leaked_sem = IPC::Semaphore->new($key_int, 0, 0); $leaked_sem->remove if defined $leaked_sem; } # Type guards: array-only methods on a hash knot { my $key = int(rand(99999)); tie my %h, 'IPC::Shareable', { key => $key, create => 1, destroy => 1 }; my $knot = tied(%h); is eval { $knot->PUSH('x'); 1 }, undef, "PUSH on hash knot croaks"; like $@, qr/Cannot push to a non-array/, "PUSH on hash knot: error message correct"; is eval { $knot->POP; 1 }, undef, "POP on hash knot croaks"; like $@, qr/Cannot pop from a non-array/, "POP on hash knot: error message correct"; is eval { $knot->SHIFT; 1 }, undef, "SHIFT on hash knot croaks"; like $@, qr/Cannot shift from a non-array/, "SHIFT on hash knot: error message correct"; is eval { $knot->UNSHIFT('x'); 1 }, undef, "UNSHIFT on hash knot croaks"; like $@, qr/Cannot unshift a non-array/, "UNSHIFT on hash knot: error message correct"; is eval { $knot->SPLICE(0, 0); 1 }, undef, "SPLICE on hash knot croaks"; like $@, qr/Cannot splice a non-array/, "SPLICE on hash knot: error message correct"; is eval { $knot->FETCHSIZE; 1 }, undef, "FETCHSIZE on hash knot croaks"; like $@, qr/Cannot fetchsize on a non-array/, "FETCHSIZE on hash knot: error message correct"; is eval { $knot->STORESIZE(5); 1 }, undef, "STORESIZE on hash knot croaks"; like $@, qr/Cannot storesize on a non-array/, "STORESIZE on hash knot: error message correct"; } # Type guard: DELETE on an array knot { my $key = int(rand(99999)); tie my @a, 'IPC::Shareable', { key => $key, create => 1, destroy => 1 }; my $knot = tied(@a); is eval { $knot->DELETE('foo'); 1 }, undef, "DELETE on array knot croaks"; like $@, qr/Cannot delete from a non-hash/, "DELETE on array knot: error message correct"; } done_testing(); IPC-Shareable-1.19/t/76-sem-resources.t000644 000765 000024 00000002516 15211457205 017720 0ustar00stevestaff000000 000000 use warnings; use strict; use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(sem_set_limit low_sem_resources relieve_ipc_pressure); # Coverage for the platform resource-awareness helpers in IPCShareableTest. # Tests that create many tied variables use these to detect a small SysV # semaphore-set budget (eg. OpenBSD, kern.seminfo.semmni = 10) and release IPC # as they go, rather than exhausting the host. my $limit = sem_set_limit(); ok ! defined $limit || $limit =~ /^\d+$/, 'sem_set_limit() returns undef or a non-negative integer'; my $low = low_sem_resources(); ok $low == 0 || $low == 1, 'low_sem_resources() returns a boolean'; is $low, (defined $limit && $limit < IPCShareableTest::LOW_SEM_SETS() ? 1 : 0), 'low_sem_resources() reflects the measured limit against the threshold'; is low_sem_resources(), $low, 'low_sem_resources() is stable (cached)'; if (defined $limit) { diag "host reports $limit SysV semaphore set(s); threshold is " . IPCShareableTest::LOW_SEM_SETS(); } else { is $low, 0, 'an undeterminable limit is treated as not-constrained'; } # relieve_ipc_pressure() must run cleanly whether or not the host is constrained # (it is a no-op unless low_sem_resources() is true). ok eval { relieve_ipc_pressure(); 1 }, 'relieve_ipc_pressure() runs without error'; done_testing(); IPC-Shareable-1.19/t/66-protected_persist.t000644 000765 000024 00000006010 15211722417 020656 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw( assert_clean_process barrier_new barrier_release barrier_wait unique_glue ); use Test::SharedFork; my $protect_lock = 441; # Test: re-attaching to a protected segment in the same process auto-populates # the protected attribute from the semaphore. { tie my %p, 'IPC::Shareable', { key => unique_glue('pp66a'), create => 1, exclusive => 1, destroy => 0, protected => $protect_lock, serializer => 'storable', }; $p{val} = 'same_proc'; # Attach again (no protected specified) tie my %p2, 'IPC::Shareable', { key => unique_glue('pp66a'), create => 0, serializer => 'storable', }; is tied(%p2)->attributes('protected'), $protect_lock, "Same-process re-attach: protected auto-populated from semaphore ok"; is $p2{val}, 'same_proc', "Same-process re-attach: can read segment data ok"; IPC::Shareable->clean_up_protected($protect_lock); } # Test: attaching from a forked child process auto-populates protected even # when the caller omits the protected option. child's clean_up_all then # correctly skips the segment. { my $ready = barrier_new(); # parent -> child: protected segment created my $pid = fork; die "Cannot fork: $!" unless defined $pid; if ($pid == 0) { # child: wait for parent to create segment then attach barrier_wait($ready); tie my %child_p, 'IPC::Shareable', { key => unique_glue('pp66b'), create => 0, serializer => 'storable', }; is tied(%child_p)->attributes('protected'), $protect_lock, "Child: protected auto-populated from semaphore when attaching with create=>0 ok"; is $child_p{val}, 'cross_proc', "Child: can read protected segment data ok"; # clean_up_all should skip this segment because protected was # restored from the semaphore. IPC::Shareable->clean_up_all; exit(0); } else { # parent: create the protected segment, wake child, then verify tie my %p, 'IPC::Shareable', { key => unique_glue('pp66b'), create => 1, exclusive => 1, destroy => 0, protected => $protect_lock, serializer => 'storable', }; $p{val} = 'cross_proc'; barrier_release($ready); waitpid($pid, 0); # Segment must have survived child's clean_up_all is $p{val}, 'cross_proc', "Parent: protected segment data intact after child's clean_up_all ok"; is tied(%p)->attributes('protected'), $protect_lock, "Parent: protected attribute unchanged after child's clean_up_all ok"; IPC::Shareable->clean_up_protected($protect_lock); } } IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/79-sem-create-orphan.t000644 000765 000024 00000021272 15222763430 020443 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::SysV qw(IPC_RMID IPC_STAT); use IPC::Semaphore; use Errno qw(ENOSPC); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue require_free_sem_sets); require_free_sem_sets(); use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); # Coverage for the _tie() fix: when the shared memory segment is created but the # semaphore set cannot be (eg. ENOSPC once the host's semaphore limit is hit -- # as on OpenBSD, where kern.seminfo.semmni defaults to 10), the just-created # segment must be removed before croaking rather than orphaned. The removal is # gated on ownership: a pure attacher (create => 0) must NEVER remove a segment # that another process owns. # # IPC::Semaphore->new is forced to fail with a block-scoped typeglob override -- # the same approach t/60-exceptions.t uses, because Mock::Sub 1.08 mishandles # return_value => undef, so a bare `return` (failure in any context) is used. # # Before the fix, t/60-exceptions.t had to clean up the orphaned segment by hand # ("created before IPC::Semaphore->new failed, so it is not in any register"). # These tests assert that orphan no longer happens. # --------------------------------------------------------------------------- # Creator: a failed semaphore create removes the just-created segment (no orphan). # --------------------------------------------------------------------------- { my $glue = unique_glue('sem-fail-creator'); my $key_int = IPC::Shareable::_key_str_to_int($glue); my $before = scalar keys %{ IPC::Shareable->global_register }; { no warnings 'redefine'; local *IPC::Semaphore::new = sub { return }; my $ok = eval { tie my $s, 'IPC::Shareable', { key => $glue, create => 1, destroy => 1 }; 1; }; ok ! $ok, 'creator: tie croaks when the semaphore set cannot be created'; like $@, qr/Could not create semaphore set/, '...with the expected message'; } my $leaked = shmget($key_int, 0, 0); ok ! defined $leaked, 'creator: the just-created segment was removed, not orphaned'; is scalar keys %{ IPC::Shareable->global_register }, $before, 'creator: nothing left dangling in the global register'; # Safety net: if a regression reintroduces the leak, don't let it escape this # test and pollute the host's IPC table. shmctl($leaked, IPC_RMID, 0) if defined $leaked; } # --------------------------------------------------------------------------- # The croak preserves the ORIGINAL errno across the cleanup removal, so the # message still names the real cause (eg. ENOSPC) rather than the result of the # internal shmctl used to remove the orphaned segment. # --------------------------------------------------------------------------- { my $glue = unique_glue('sem-fail-errno'); my $enospc = do { local $! = ENOSPC; "$!" }; { no warnings 'redefine'; local *IPC::Semaphore::new = sub { $! = ENOSPC; return }; eval { tie my $s, 'IPC::Shareable', { key => $glue, create => 1, destroy => 1 }; 1; }; } like $@, qr/Could not create semaphore set: \Q$enospc\E/, 'croak preserves the original errno across the orphan-cleanup removal'; } # --------------------------------------------------------------------------- # Lock-acquire failure: if the semaphore op fails right after the segment and # its semaphore were created (before the knot is registered), both are torn # down before croaking rather than orphaned. # --------------------------------------------------------------------------- { my $glue = unique_glue('op-fail-creator'); my $key_int = IPC::Shareable::_key_str_to_int($glue); { no warnings 'redefine'; local *IPC::Semaphore::op = sub { 0 }; # Fail every semop my $ok = eval { tie my $s, 'IPC::Shareable', { key => $glue, create => 1, destroy => 1 }; 1; }; ok ! $ok, 'lock-acquire failure: tie croaks'; like $@, qr/Could not obtain semaphore set lock/, '...with the expected message'; } my $leaked_seg = shmget($key_int, 0, 0); ok ! defined $leaked_seg, 'lock-acquire failure: the just-created segment was removed, not orphaned'; my $leaked_sem = IPC::Semaphore->new($key_int, 0, 0); ok ! defined $leaked_sem, 'lock-acquire failure: the just-created semaphore set was removed too'; # Safety net shmctl($leaked_seg, IPC_RMID, 0) if defined $leaked_seg; $leaked_sem->remove if defined $leaked_sem; } # --------------------------------------------------------------------------- # Attacher: a failed semaphore create must NOT remove a segment we didn't create. # (Guards against an over-aggressive fix that removes the segment unconditionally.) # --------------------------------------------------------------------------- { my $glue = unique_glue('sem-fail-attacher'); my $key_int = IPC::Shareable::_key_str_to_int($glue); tie my %owner, 'IPC::Shareable', { key => $glue, create => 1, destroy => 1 }; %owner = (alive => 1); ok defined shmget($key_int, 0, 0), 'attacher: owner segment exists to begin with'; { no warnings 'redefine'; local *IPC::Semaphore::new = sub { return }; my $ok = eval { tie my %a, 'IPC::Shareable', { key => $glue, create => 0 }; 1; }; ok ! $ok, 'attacher: tie croaks when the semaphore set cannot be created'; like $@, qr/Could not create semaphore set/, '...with the expected message'; } ok defined shmget($key_int, 0, 0), "attacher: the owner's segment was NOT removed by the failed attach"; is $owner{alive}, 1, "attacher: the owner's data is intact"; IPC::Shareable::clean_up_all; } # --------------------------------------------------------------------------- # IPC_PRIVATE: a failed semaphore create removes the just-created private # segment. shmget(IPC_PRIVATE) ALWAYS creates a fresh segment regardless of the # 'create' attribute (which a bare tie does not set), and a private segment is # unreachable by key after the croak -- before this fix it leaked # unconditionally, invisible even to clean_up_testing() (which skips key 0). # This was the ~4-segments-per-run growth observed on wedged OpenBSD smokers. # The segment id is captured via a pass-through wrap of SharedMem::new so the # assertion is id-exact and immune to unrelated IPC activity on the host. # --------------------------------------------------------------------------- { my $seg_id; { no warnings 'redefine'; my $real_new = \&IPC::Shareable::SharedMem::new; local *IPC::Shareable::SharedMem::new = sub { my $seg = $real_new->(@_); $seg_id = $seg->id if defined $seg; return $seg; }; local *IPC::Semaphore::new = sub { $! = ENOSPC; return }; my $ok = eval { tie my $s, 'IPC::Shareable'; # No key, no create: IPC_PRIVATE 1; }; ok ! $ok, 'IPC_PRIVATE: tie croaks when the semaphore set cannot be created'; like $@, qr/Could not create semaphore set/, '...with the expected message'; } ok defined $seg_id, 'IPC_PRIVATE: a private segment was created during the failed tie'; my $stat_buf = ''; ok ! shmctl($seg_id, IPC_STAT, $stat_buf), 'IPC_PRIVATE: the private segment was removed, not orphaned'; # Safety net: reclaim it if a regression reintroduces the leak shmctl($seg_id, IPC_RMID, 0) if defined $seg_id; } # --------------------------------------------------------------------------- # Regression: the success path is unaffected -- the new branch only runs on a # semaphore-create failure. A normal tie, a ref fan-out, and cleanup all work. # --------------------------------------------------------------------------- { my $glue = unique_glue('sem-ok-scalar'); my $key_int = IPC::Shareable::_key_str_to_int($glue); { tie my $s, 'IPC::Shareable', { key => $glue, create => 1, destroy => 1 }; $s = 'hello'; is $s, 'hello', 'success path: plain scalar round-trips'; ok defined shmget($key_int, 0, 0), 'success path: segment is live while tied'; } IPC::Shareable::clean_up_all; ok ! defined shmget($key_int, 0, 0), 'success path: segment removed on cleanup'; } { tie my $s, 'IPC::Shareable', { key => unique_glue('sem-ok-ref'), create => 1, destroy => 1, size => 4096 }; $s = { a => 1, b => [2, 3] }; is $s->{a}, 1, 'success path: ref fan-out child readable'; is $s->{b}[1], 3, 'success path: nested child readable'; IPC::Shareable::clean_up_all; } IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/PaxHeader/30-ipcref.t000644 000765 000024 00000000210 15222763263 020326 xustar00stevestaff000000 000000 30 mtime=1783359155.487203731 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/30-ipcref.t000644 000765 000024 00000010375 15222763263 016372 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw( assert_clean_process barrier_new barrier_release barrier_wait unique_glue require_free_sem_sets ); require_free_sem_sets(); use Test::SharedFork; # serializer: storable { my $ready = barrier_new(); # parent -> child: segments created my($av, $hv); my $pid = fork; defined $pid or die "Cannot fork : $!"; if ($pid == 0) { # child barrier_wait($ready); tie $hv, 'IPC::Shareable', unique_glue('hash1'), { destroy => 0 , serializer => 'storable' }; tie $av, 'IPC::Shareable', unique_glue('arry1'), { destroy => 0 , serializer => 'storable' }; is $hv, 'baz', "storable: child: HV is 'baz' ok"; is $av, 'bong', "storable: child: AV is 'bong' ok"; $hv = { }; $av = [ ]; $av->[1]->[2] = 'beep'; $av->[2]->[3] = 'bang'; is $av->[1]->[2], 'beep', "storable: child: nested AV 1 has 'beep' ok"; is $av->[2]->[3], 'bang', "storable: child: nested AV 2 has 'bang' ok"; $hv->{blip}->{blarp} = 'blurp'; $hv->{flip}->{flop} = 'flurp'; is $hv->{blip}->{blarp}, 'blurp', "storable: child: nested HV 1 is 'blurp' ok"; is $hv->{flip}->{flop}, 'flurp', "storable: child: nested HV 2 is 'flurp' ok"; exit; } else { # parent tie $hv, 'IPC::Shareable', unique_glue('hash1'), { create => 1, destroy => 1 , serializer => 'storable' }; tie $av, 'IPC::Shareable', unique_glue('arry1'), { create => 1, destroy => 1 , serializer => 'storable' }; $hv = 'baz'; $av = 'bong'; barrier_release($ready); waitpid($pid, 0); is $hv->{blip}->{blarp}, 'blurp', "storable: parent: nested HV 1 is 'blurp' ok"; is $hv->{flip}->{flop}, 'flurp', "storable: parent: nested HV 2 is 'flurp' ok"; is $av->[1]->[2], 'beep', "storable: parent: nested AV 1 has 'beep' ok"; is $av->[2]->[3], 'bang', "storable: parent: nested AV 2 has 'bang' ok"; IPC::Shareable->clean_up_all; is defined $av, '', "storable: AV cleaned after clean_up_all()"; is defined $hv, '', "storable: HV cleaned after clean_up_all()"; } } # serializer: json { my $ready = barrier_new(); # parent -> child: segments created my($av, $hv); my $pid = fork; defined $pid or die "Cannot fork : $!"; if ($pid == 0) { # child barrier_wait($ready); tie $hv, 'IPC::Shareable', unique_glue('hash1j'), { destroy => 0, serializer => 'json' }; tie $av, 'IPC::Shareable', unique_glue('arry1j'), { destroy => 0, serializer => 'json' }; is $hv, 'baz', "json: child: HV is 'baz' ok"; is $av, 'bong', "json: child: AV is 'bong' ok"; $hv = { }; $av = [ ]; $av->[1]->[2] = 'beep'; $av->[2]->[3] = 'bang'; is $av->[1]->[2], 'beep', "json: child: nested AV 1 has 'beep' ok"; is $av->[2]->[3], 'bang', "json: child: nested AV 2 has 'bang' ok"; $hv->{blip}->{blarp} = 'blurp'; $hv->{flip}->{flop} = 'flurp'; is $hv->{blip}->{blarp}, 'blurp', "json: child: nested HV 1 is 'blurp' ok"; is $hv->{flip}->{flop}, 'flurp', "json: child: nested HV 2 is 'flurp' ok"; exit; } else { # parent tie $hv, 'IPC::Shareable', unique_glue('hash1j'), { create => 1, destroy => 1, serializer => 'json' }; tie $av, 'IPC::Shareable', unique_glue('arry1j'), { create => 1, destroy => 1, serializer => 'json' }; $hv = 'baz'; $av = 'bong'; barrier_release($ready); waitpid($pid, 0); is $hv->{blip}->{blarp}, 'blurp', "json: parent: nested HV 1 is 'blurp' ok"; is $hv->{flip}->{flop}, 'flurp', "json: parent: nested HV 2 is 'flurp' ok"; is $av->[1]->[2], 'beep', "json: parent: nested AV 1 has 'beep' ok"; is $av->[2]->[3], 'bang', "json: parent: nested AV 2 has 'bang' ok"; IPC::Shareable->clean_up_all; is defined $av, '', "json: AV cleaned after clean_up_all()"; is defined $hv, '', "json: HV cleaned after clean_up_all()"; } } IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/38-lsync.t000644 000765 000024 00000004607 15211510760 016251 0ustar00stevestaff000000 000000 # Test of asynchronous hash access courtesy of Tim Fries use warnings; use strict; use Carp; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue); # A two-pipe handshake replaces the old SIGALRM/sleep handshake, which had a # lost-wakeup race: a signal delivered in the window after the "unless $awake" # check but before sleep() blocked the process forever (it deadlocked under # emulation). Each writer closes its pipe end right after the single write, so # the read unblocks (flush + EOF) and cannot miss the wakeup. Same idiom as # t/26, t/19, and t/24. my $glue = unique_glue('hobj'); pipe(my $ready_r, my $ready_w) or die "Cannot create pipe: $!"; # parent -> child pipe(my $done_r, my $done_w) or die "Cannot create pipe: $!"; # child -> parent my $pid = fork; defined $pid or die "Cannot fork: $!"; if ($pid == 0) { # child: attach once the parent has created the segment, write three keys, # tell the parent, then exit close $ready_w; close $done_r; <$ready_r>; # wait: parent has created the segment close $ready_r; tie my %thash, 'IPC::Shareable', $glue, { destroy => 0, serializer => 'storable' }; $thash{'foo'} = "marlinspike"; $thash{'bar'} = "ballyhoo"; $thash{'quux'} = "calvinball"; print $done_w "done\n"; # tell parent: keys written close $done_w; exit; } # parent close $ready_r; close $done_w; tie my %thash, 'IPC::Shareable', $glue, { create => 'yes', serializer => 'storable' }; print $ready_w "go\n"; # segment exists; child may attach and write close $ready_w; <$done_r>; # block until the child has written its keys close $done_r; $thash{'intel'} = "expensive"; $thash{'amd'} = "volthungry"; $thash{'cyrix'} = "mia"; waitpid($pid, 0); is defined $thash{'foo'}, 1, "parent: thash foo defined"; is $thash{'foo'}, 'marlinspike', "parent: thash foo val is good"; is defined $thash{'bar'}, 1, "parent: thash bar defined"; is $thash{'bar'}, 'ballyhoo', "parent: thash bar val is good"; is defined $thash{'quux'}, 1, "parent: thash quux defined"; is $thash{'quux'}, 'calvinball', "parent: thash quux val is good"; IPC::Shareable->clean_up_all; is %thash, '', "data cleaned up after clean_up_all()"; IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/24-lock_fork_blocking.t000644 000765 000024 00000023043 15222763365 020745 0ustar00stevestaff000000 000000 use warnings; use strict; # Cross-process LOCK_SH / LOCK_EX blocking tests. # # Each test forks a writer child that: # 1. acquires LOCK_EX on the shared variable # 2. writes 'updated' to it # 3. signals the parent via a pipe that LOCK_EX is held # 4. sleeps 0.3 s (holding the lock) # 5. releases LOCK_EX and exits # # The parent only attempts LOCK_SH *after* receiving the pipe signal, so the # semaphore wait-for-writers-zero operation is guaranteed to block until the # child releases LOCK_EX. The correct post-write value ('updated') is then # readable once the shared lock is granted. use IPC::Shareable qw(:lock); IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use Test::SharedFork; use Time::HiRes qw(time); use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(unique_glue assert_clean require_free_sem_sets); require_free_sem_sets(); # --- Test 1: LOCK_SH blocks until LOCK_EX released (enforced_write_locking disabled) --- { my ($r, $w); pipe($r, $w) or die "Cannot create pipe: $!"; tie my $sv, 'IPC::Shareable', { key => unique_glue('LFBK1'), create => 1, destroy => 1, enforced_write_locking => 0, enforced_read_locking => 0, serializer => 'storable', }; $sv = 'initial'; my $pid = fork; defined $pid or die "Cannot fork: $!"; if ($pid == 0) { # writer child close $r; my $wt = tied $sv; $wt->lock(LOCK_EX); $sv = 'updated'; print $w "ready\n"; close $w; select(undef, undef, undef, 0.3); # hold lock so parent definitely blocks $wt->unlock; exit 0; } # parent (reader) close $w; <$r>; # wait until child holds LOCK_EX and has written 'updated' close $r; my $ready = time(); my $rt = tied $sv; my $t0 = time(); my $got = $rt->lock(LOCK_SH); # blocks here until child releases LOCK_EX my $t1 = time(); my $wait = $t1 - $t0; # The child holds LOCK_EX for 0.3s after signalling readiness, so the floor # on the observed wait is whatever remained of that window when this # process finally issued the lock call. On a loaded smoker the parent can # be descheduled after the pipe read for longer than the whole window -- a # fixed 0.28s floor then fails with waits as low as 0.000s (seen on CPAN # testers). The functional assertions above are unaffected. my $floor = 0.3 - ($t0 - $ready) - 0.02; $floor = 0 if $floor < 0; is $got, 1, "LOCK_SH (enforced_write_locking off): lock() returns 1 after LOCK_EX released"; is $sv, 'updated', "LOCK_SH (enforced_write_locking off): reads value written by LOCK_EX holder"; ok( $wait >= $floor, sprintf("Reader blocked on LOCK_SH (waited %.3fs >= floor %.3fs)", $wait, $floor), ); $rt->unlock; waitpid($pid, 0); } # --- Test 2: LOCK_SH blocks until LOCK_EX released (enforced_write_locking enabled) --- { my ($r, $w); pipe($r, $w) or die "Cannot create pipe: $!"; tie my $sv, 'IPC::Shareable', { key => unique_glue('LFBK2'), create => 1, destroy => 1, enforced_write_locking => 1, enforced_read_locking => 1, serializer => 'storable', }; $sv = 'initial'; my $pid = fork; defined $pid or die "Cannot fork: $!"; if ($pid == 0) { # writer child close $r; my $wt = tied $sv; $wt->lock(LOCK_EX); $sv = 'updated'; print $w "ready\n"; close $w; select(undef, undef, undef, 0.3); $wt->unlock; exit 0; } # parent (reader) close $w; <$r>; close $r; my $rt = tied $sv; my $got = $rt->lock(LOCK_SH); is $got, 1, "LOCK_SH (enforced_write_locking on): lock() returns 1 after LOCK_EX released"; is $sv, 'updated', "LOCK_SH (enforced_write_locking on): reads value written by LOCK_EX holder"; $rt->unlock; waitpid($pid, 0); } # --- Test 3: LOCK_SH|LOCK_NB returns 0 immediately while LOCK_EX is held --- { my ($r, $w); pipe($r, $w) or die "Cannot create pipe: $!"; tie my $sv, 'IPC::Shareable', { key => unique_glue('LFBK3'), create => 1, destroy => 1, serializer => 'storable', }; $sv = 'initial'; my $pid = fork; defined $pid or die "Cannot fork: $!"; if ($pid == 0) { # writer child holds LOCK_EX for long enough that the parent's # non-blocking attempt definitely races against it close $r; my $wt = tied $sv; $wt->lock(LOCK_EX); print $w "ready\n"; close $w; select(undef, undef, undef, 0.5); $wt->unlock; exit 0; } # parent close $w; <$r>; # writer now holds LOCK_EX close $r; my $rt = tied $sv; my $got = $rt->lock(LOCK_SH | LOCK_NB); is $got, 0, "LOCK_SH|LOCK_NB: returns 0 (would block) while LOCK_EX is held"; is $rt->{_lock}, 0, "LOCK_SH|LOCK_NB: _lock remains 0 when non-blocking attempt fails"; waitpid($pid, 0); } # --- Test 4: Two readers with LOCK_SH both block until LOCK_EX released --- { my ($r, $w); pipe($r, $w) or die "Cannot create pipe: $!"; tie my $sv, 'IPC::Shareable', { key => unique_glue('LFBK4'), create => 1, destroy => 1, enforced_write_locking => 0, enforced_read_locking => 0, serializer => 'storable', }; $sv = 'initial'; my $writer_pid = fork; defined $writer_pid or die "Cannot fork writer: $!"; if ($writer_pid == 0) { close $r; my $wt = tied $sv; $wt->lock(LOCK_EX); $sv = 'updated'; print $w "ready\n"; close $w; select(undef, undef, undef, 0.3); $wt->unlock; exit 0; } close $w; <$r>; # writer now holds LOCK_EX and has written 'updated' close $r; # Fork two reader children; both block on LOCK_SH until writer releases EX. # Multiple concurrent LOCK_SH holders are permitted by the SysV semaphore # scheme, so both unblock together once SEM_WRITERS drops to 0. my @reader_pids; for my $n (1, 2) { my $rpid = fork; defined $rpid or die "Cannot fork reader $n: $!"; if ($rpid == 0) { my $rt = tied $sv; my $got = $rt->lock(LOCK_SH); is $got, 1, "LOCK_SH two readers (reader $n): lock() returns 1 after LOCK_EX released"; is $sv, 'updated', "LOCK_SH two readers (reader $n): reads value written by LOCK_EX holder"; $rt->unlock; exit 0; } push @reader_pids, $rpid; } waitpid($writer_pid, 0); waitpid($_, 0) for @reader_pids; } # --- Test 5: LOCK_EX blocks until previous LOCK_EX released --- { my ($r, $w); pipe($r, $w) or die "Cannot create pipe: $!"; tie my $sv, 'IPC::Shareable', { key => unique_glue('LFBK5'), create => 1, destroy => 1, serializer => 'storable', }; $sv = 'initial'; my $pid = fork; defined $pid or die "Cannot fork: $!"; if ($pid == 0) { # first writer child close $r; my $wt = tied $sv; $wt->lock(LOCK_EX); $sv = 'updated'; print $w "ready\n"; close $w; select(undef, undef, undef, 0.3); # hold lock so parent definitely blocks $wt->unlock; exit 0; } # parent (second writer) close $w; <$r>; # wait until child holds LOCK_EX and has written 'updated' close $r; my $ready = time(); my $rt = tied $sv; my $t0 = time(); my $got = $rt->lock(LOCK_EX); # blocks here until child releases LOCK_EX my $t1 = time(); my $wait = $t1 - $t0; # Dynamic floor: see the LOCK_SH block in Test 1 for why a fixed 0.28s # floor is a race on loaded smokers. my $floor = 0.3 - ($t0 - $ready) - 0.02; $floor = 0 if $floor < 0; is $got, 1, "LOCK_EX: lock() returns 1 after previous LOCK_EX released"; is $sv, 'updated', "LOCK_EX: reads value written by previous LOCK_EX holder"; ok( $wait >= $floor, sprintf("Writer blocked on LOCK_EX (waited %.3fs >= floor %.3fs)", $wait, $floor), ); $rt->unlock; waitpid($pid, 0); } # --- Test 6: LOCK_EX|LOCK_NB returns 0 immediately while another LOCK_EX is held --- { my ($r, $w); pipe($r, $w) or die "Cannot create pipe: $!"; tie my $sv, 'IPC::Shareable', { key => unique_glue('LFBK6'), create => 1, destroy => 1, serializer => 'storable', }; $sv = 'initial'; my $pid = fork; defined $pid or die "Cannot fork: $!"; if ($pid == 0) { # first writer child holds LOCK_EX for long enough that the parent's # non-blocking attempt definitely races against it close $r; my $wt = tied $sv; $wt->lock(LOCK_EX); print $w "ready\n"; close $w; select(undef, undef, undef, 0.5); $wt->unlock; exit 0; } # parent (second writer) close $w; <$r>; # writer now holds LOCK_EX close $r; my $rt = tied $sv; my $got = $rt->lock(LOCK_EX | LOCK_NB); is $got, 0, "LOCK_EX|LOCK_NB: returns 0 (would block) while another LOCK_EX is held"; is $rt->{_lock}, 0, "LOCK_EX|LOCK_NB: _lock remains 0 when non-blocking attempt fails"; waitpid($pid, 0); } IPC::Shareable::_end; assert_clean(map { unique_glue($_) } qw(LFBK1 LFBK2 LFBK3 LFBK4 LFBK5 LFBK6)); done_testing; IPC-Shareable-1.19/t/PaxHeader/69-testing_flag.t000644 000765 000024 00000000210 15222763263 021540 xustar00stevestaff000000 000000 30 mtime=1783359155.487841106 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/69-testing_flag.t000644 000765 000024 00000015510 15222763263 017600 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable qw(SEM_TESTING); use IPC::Semaphore; use String::CRC32; use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue require_free_sem_sets); require_free_sem_sets(); my $DIST = unique_glue('IPC::Shareable::Test::69'); my $expected_hash = (String::CRC32::crc32($DIST) & 0x7FFF) || 1; # 1. testing_set() croaks with no argument or empty string { my $ok = eval { IPC::Shareable->testing_set(); 1 }; is $ok, undef, "testing_set() croaks with no argument"; like $@, qr/requires/, "...error message mentions 'requires'"; $ok = eval { IPC::Shareable->testing_set(''); 1 }; is $ok, undef, "testing_set() croaks with empty string"; like $@, qr/requires/, "...error message mentions 'requires'"; } # 2. Explicit testing => $DIST without testing_set() — 5-slot semaphore, # SEM_TESTING holds the correct hash { tie my %h, 'IPC::Shareable', { key => unique_glue('tf02'), create => 1, destroy => 1, testing => $DIST, }; my $knot = tied(%h); my $sem = $knot->sem; my $stat = $sem->stat; is $stat->nsems, 5, "Segment created with testing => DIST has 5 semaphore slots"; is $sem->getval(SEM_TESTING), $expected_hash, "SEM_TESTING holds the correct CRC32 hash of the dist name"; is $knot->attributes('testing'), $DIST, "attributes('testing') returns original dist string on the creating process"; tied(%h)->clean_up_all; } # 3. Segment created without testing => has 4 semaphore slots { tie my %h, 'IPC::Shareable', { key => unique_glue('tf03'), create => 1, destroy => 1, }; my $knot = tied(%h); my $stat = $knot->sem->stat; is $stat->nsems, 4, "Segment without testing => has 4 semaphore slots"; tied(%h)->clean_up_all; } # 4. testing_set() — subsequent ties auto-tag; testing => 0 opts out { IPC::Shareable->testing_set($DIST); tie my %auto, 'IPC::Shareable', { key => unique_glue('tf04a'), create => 1, destroy => 1, }; my $auto_stat = tied(%auto)->sem->stat; is $auto_stat->nsems, 5, "Auto-tagged tie after testing_set() has 5 slots"; is tied(%auto)->sem->getval(SEM_TESTING), $expected_hash, "Auto-tagged tie has correct SEM_TESTING hash"; tie my %no, 'IPC::Shareable', { key => unique_glue('tf04b'), create => 1, destroy => 1, testing => 0, }; my $no_stat = tied(%no)->sem->stat; is $no_stat->nsems, 4, "testing => 0 opts out of auto-tagging (4 slots)"; tied(%auto)->clean_up_all; tied(%no)->clean_up_all; # $_testing_dist stays set; that's the realistic test-file pattern. } # 5. clean_up_testing() removes only matching segments, not others { my $other_dist = unique_glue('IPC::Shareable::Test::OTHER'); tie my %target, 'IPC::Shareable', { key => unique_glue('tf05t'), create => 1, destroy => 0, # must survive to be found by clean_up_testing testing => $DIST, }; tie my %other, 'IPC::Shareable', { key => unique_glue('tf05o'), create => 1, destroy => 1, testing => $other_dist, }; my $segs_mid = keys %{ IPC::Shareable::global_register() }; cmp_ok $segs_mid, '>=', 2, "At least 2 segments in register before cleanup"; my $removed = IPC::Shareable::clean_up_testing($DIST); is $removed, 1, "clean_up_testing() removed exactly 1 segment (the DIST one)"; # The other dist segment should still exist my $reg = IPC::Shareable::global_register(); my $other_knot = tied(%other); ok exists $reg->{ $other_knot->seg->id }, "The other-dist segment was NOT removed by clean_up_testing(DIST)"; tied(%other)->clean_up_all; } # 6. clean_up_testing() finds orphans (segments not in global_register) { # Create a segment, capture its key, clear global_register by untying my $key_str = unique_glue('tf06o'); { tie my %orphan, 'IPC::Shareable', { key => $key_str, create => 1, destroy => 0, testing => $DIST, }; # Let it go out of scope without destroy — simulates a crash leaving orphan } # At this point the segment still exists on the system but the inner # scope's tied variable has been untied — clean_up_testing() must still # find and remove it via the system-wide ipcs scan. my $removed = IPC::Shareable::clean_up_testing($DIST); cmp_ok $removed, '>=', 1, "clean_up_testing() removed the orphaned segment not in global_register"; } # 7. Child/nested segments inherit the testing attribute { IPC::Shareable->testing_set($DIST); tie my %parent, 'IPC::Shareable', { key => unique_glue('tf07'), create => 1, destroy => 1, }; $parent{nested} = { inner => 42 }; # triggers _magic_tie for child my $reg = IPC::Shareable::global_register(); my @children = grep { my $k = $reg->{$_}; defined $k && $k->attributes('magic') } keys %$reg; my $child_knot = $reg->{ $children[0] }; my $child_stat = $child_knot->sem->stat; is $child_stat->nsems, 5, "Child segment created via _magic_tie has 5 semaphore slots"; is $child_knot->sem->getval(SEM_TESTING), $expected_hash, "Child segment SEM_TESTING holds the correct hash"; tied(%parent)->clean_up_all; } # 8. clean_up_testing() ignores protected — both-attributed segments are removed { tie my %both, 'IPC::Shareable', { key => unique_glue('tf08'), create => 1, destroy => 0, protected => 9999, testing => $DIST, }; my $reg = IPC::Shareable::global_register(); my $knot = tied(%both); my $seg_id = $knot->seg->id; ok exists $reg->{$seg_id}, "Both-attributed segment is in register before cleanup"; my $removed = IPC::Shareable::clean_up_testing($DIST); is $removed, 1, "clean_up_testing() removed the protected+testing segment"; $reg = IPC::Shareable::global_register(); ok !exists $reg->{$seg_id}, "Both-attributed segment is gone from register"; } # 9. clean_up_testing() returns the count of removed segments { tie my %a, 'IPC::Shareable', { key => unique_glue('tf09a'), create => 1, destroy => 0, testing => $DIST }; tie my %b, 'IPC::Shareable', { key => unique_glue('tf09b'), create => 1, destroy => 0, testing => $DIST }; my $removed = IPC::Shareable::clean_up_testing($DIST); is $removed, 2, "clean_up_testing() returns count of removed segments (2)"; } # 10. Seg/sem counts return to baseline after final cleanup { # Catch any leftovers from this test file IPC::Shareable::clean_up_testing($DIST); IPC::Shareable::clean_up_all(); IPC::Shareable::_end(); } assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/PaxHeader/65-clean_protected.t000644 000765 000024 00000000210 15222763263 022221 xustar00stevestaff000000 000000 30 mtime=1783359155.487562356 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/65-clean_protected.t000644 000765 000024 00000004607 15222763263 020266 0ustar00stevestaff000000 000000 use warnings; use strict; use Data::Dumper; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue require_free_sem_sets); require_free_sem_sets(); my $protect_lock = 292; # Exception testing { my $no_key_ok = eval { IPC::Shareable::clean_up_protected; 1; }; is $no_key_ok, undef, "clean_up_protected() croaks if no key sent in"; like $@, qr/requires/, "...and error msg is sane"; my $key_not_int_ok = eval { IPC::Shareable::clean_up_protected('asf'); 1; }; is $no_key_ok, undef, "clean_up_protected() croaks if key isn't an int"; like $@, qr/integer/, "...and error msg is sane"; tie my %test, 'IPC::Shareable', { key => unique_glue('k100'), create => 1, exclusive => 1, destroy => 1, protected => 500, serializer => 'storable', }; $test{a}{b} = 2; my $segs = keys %{ IPC::Shareable::global_register() }; is $segs, 2, "Before clean_up_protected(), global register has 2 segments ok"; tied(%test)->clean_up_protected(500); $segs = keys %{ IPC::Shareable::global_register() }; is $segs, 0, "After clean_up_protected() (method call), global register has 0 segments ok"; is eval { IPC::Shareable::clean_up_protected(999999); 1; }, 1, "A call to clean_up_protected() succeeds even if protect key no exist"; } tie my %p, 'IPC::Shareable', { key => unique_glue('k10'), create => 1, exclusive => 1, destroy => 1, protected => $protect_lock, serializer => 'storable', }; tie my %u, 'IPC::Shareable', { key => unique_glue('k20'), create => 1, exclusive => 1, destroy => 1, serializer => 'storable', }; $p{one}{two} = 1; $u{one}{two} = 1; my $segs = keys %{ IPC::Shareable::global_register() }; is $segs, 4, "Before clean_up_all(), global register has 4 segments ok"; IPC::Shareable::clean_up_all; $segs = keys %{ IPC::Shareable::global_register() }; is $segs, 2, "After clean_up_all(), global register has 2 segments ok"; IPC::Shareable::clean_up_protected($protect_lock); $segs = keys %{ IPC::Shareable::global_register() }; is $segs, 0, "After clean_up_protected(), global register has 0 segments ok"; IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/45-private_json_nested.t000644 000765 000024 00000003417 15207650136 021171 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process); # Under IPC_PRIVATE the Storable path lets child segments inherit IPC_PRIVATE, # but the JSON path forces a random non-zero key so the child can be referenced # from the encoded blob. See _magic_tie at Shareable.pm:1567. # --- JSON: nested child under IPC_PRIVATE parent must have a non-zero key --- { my $k = tie my %h, 'IPC::Shareable', { create => 1, destroy => 1, serializer => 'json', }; is $k->{_key}, 0, "JSON parent created with default IPC_PRIVATE (key == 0)"; $h{nested} = { x => 42 }; my $child_knot = tied %{ $h{nested} }; ok $child_knot, "JSON nested ref: child is tied ok"; isnt $child_knot->{_key}, 0, "JSON nested under IPC_PRIVATE: child key is random/non-zero (not IPC_PRIVATE)"; is $h{nested}{x}, 42, "JSON nested data readable through parent ok"; IPC::Shareable->clean_up_all; } # --- Storable: nested child under IPC_PRIVATE parent inherits IPC_PRIVATE --- { my $k = tie my %h, 'IPC::Shareable', { create => 1, destroy => 1, serializer => 'storable', }; is $k->{_key}, 0, "Storable parent created with default IPC_PRIVATE (key == 0)"; $h{nested} = { x => 42 }; my $child_knot = tied %{ $h{nested} }; ok $child_knot, "Storable nested ref: child is tied ok"; is $child_knot->{_key}, 0, "Storable nested under IPC_PRIVATE: child key is also IPC_PRIVATE (legacy)"; is $h{nested}{x}, 42, "Storable nested data readable through parent ok"; IPC::Shareable->clean_up_all; } IPC::Shareable::_end; assert_clean_process(); done_testing;IPC-Shareable-1.19/t/62-fork_dup_rand_keys.t000644 000765 000024 00000003215 15207655146 020775 0ustar00stevestaff000000 000000 use warnings; use strict; # Test the fix to a bug where a random SHM key wasn't being created inside # of a fork() # It also regression tests a fix in global_register() where writing to the same # hash from two procs didn't update the global_register properly use IPC::Shareable qw(:lock); IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use Test::SharedFork; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue); BEGIN { if (! $ENV{ASYNC_TESTING}) { plan skip_all => "Developer only test... needs Async::Event::Interval"; } } use Async::Event::Interval; { tie my %shared_data, 'IPC::Shareable', { key => unique_glue('fork rand dup keys'), create => 1, destroy => 1, serializer => 'storable', }; my $event_one = Async::Event::Interval->new(0, sub { tied(%shared_data)->lock; $shared_data{$$}{called}++; tied(%shared_data)->unlock; }); my $event_two = Async::Event::Interval->new(0, sub { tied(%shared_data)->lock; $shared_data{$$}{called}++; tied(%shared_data)->unlock; }); $event_one->start; $event_two->start; sleep 1; $event_one->stop; $event_two->stop; my $one_pid = $event_one->pid; my $two_pid = $event_two->pid; is exists $shared_data{$one_pid}{called}, 1, "Event one got a rand shm key ok"; is exists $shared_data{$two_pid}{called}, 1, "Adding srand() ensures _shm_key_rand() gives out rand key in fork()"; IPC::Shareable::clean_up_all; } Async::Event::Interval::_end; IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/PaxHeader/93-manifest.t000644 000765 000024 00000000210 15203172270 020664 xustar00stevestaff000000 000000 30 mtime=1779233976.186037535 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/93-manifest.t000644 000765 000024 00000000451 15203172270 016722 0ustar00stevestaff000000 000000 use 5.006; use strict; use warnings; use Test::More; unless ( $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author test: RELEASE_TESTING not set" ); } my $min_tcm = 0.9; eval "use Test::CheckManifest $min_tcm"; plan skip_all => "Test::CheckManifest $min_tcm required" if $@; ok_manifest(); IPC-Shareable-1.19/t/PaxHeader/74-seg_map.t000644 000765 000024 00000000210 15222763263 020501 xustar00stevestaff000000 000000 30 mtime=1783359155.488081231 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/74-seg_map.t000644 000765 000024 00000007421 15222763263 016543 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue require_free_sem_sets); require_free_sem_sets(); # Class method call croaks { eval { IPC::Shareable->seg_map }; like $@, qr/must be called as an object method/, "seg_map: croaks when called as class method ok"; } # Single segment (scalar, no children) { my $k = tie my $sv, 'IPC::Shareable', { key => unique_glue('sm74a'), create => 1, exclusive => 1, destroy => 1 , serializer => 'storable' }; $sv = 'hello'; my $map = $k->seg_map; like $map, qr/IPC::Shareable Segment Map/, "single seg: header present ok"; like $map, qr/={10,}/, "single seg: separator present ok"; like $map, qr/\[known.*owner\]/, "single seg: known+owner tags present ok"; like $map, qr/key:\s+0x/, "single seg: key line present ok"; like $map, qr/seg_id:\s+\d+/, "single seg: seg_id present ok"; like $map, qr/sem_id:\s+\d+/, "single seg: sem_id present ok"; like $map, qr/1: SEM_MARKER=1/, "single seg: slot 1 SEM_MARKER=1 ok"; like $map, qr/2: READERS=0/, "single seg: slot 2 readers=0 ok"; like $map, qr/3: WRITERS=0/, "single seg: slot 3 writers=0 ok"; like $map, qr/4: PROTECTED=0/, "single seg: slot 4 PROTECTED=0 ok"; like $map, qr/Children:\s+\(none\)/, "single seg: no children ok"; like $map, qr/Content:\s+"hello"/, "single seg: Content shows scalar value ok"; IPC::Shareable->clean_up_all; } # Protected segment - PROTECTED semaphore slot should reflect the value { my $kp = tie my %h, 'IPC::Shareable', { key => unique_glue('sm74b'), create => 1, exclusive => 1, destroy => 0, protected => 777, serializer => 'storable', }; $h{x} = 1; my $map = $kp->seg_map; like $map, qr/PROTECTED=777/, "protected seg: PROTECTED=777 in semaphore slot ok"; IPC::Shareable->clean_up_protected(777); } # Nested segment (hash with a reference child) - parent and child both appear { my $kn = tie my %h, 'IPC::Shareable', { key => unique_glue('sm74c'), create => 1, exclusive => 1, destroy => 1 , serializer => 'storable' }; $h{nested} = { val => 42 }; # Force a read to ensure child segment is created my $val = $h{nested}{val}; my $map = $kn->seg_map; like $map, qr/Children:\s+0x[0-9a-f]+/, "nested seg: parent has child hex key ok"; like $map, qr/Content:.*/, "nested seg: parent Content shows child reference ok"; like $map, qr/Content:.*\bval\b.*"42"/, "nested seg: child Content shows its own data ok"; IPC::Shareable->clean_up_all; } # Object method only shows its own segment tree, not other segments { my $k1 = tie my $sv1, 'IPC::Shareable', { key => unique_glue('sm74d'), create => 1, exclusive => 1, destroy => 1 , serializer => 'storable' }; my $k2 = tie my $sv2, 'IPC::Shareable', { key => unique_glue('sm74e'), create => 1, exclusive => 1, destroy => 1 , serializer => 'storable' }; $sv1 = 'first'; $sv2 = 'second'; my $hex1 = $k1->{_key_hex}; my $hex2 = $k2->{_key_hex}; my $map1 = $k1->seg_map; my $map2 = $k2->seg_map; like $map1, qr/\Q$hex1\E/, "object method: shows its own segment ok"; unlike $map1, qr/\Q$hex2\E/, "object method: does not show other segments ok"; like $map2, qr/\Q$hex2\E/, "object method k2: shows its own segment ok"; unlike $map2, qr/\Q$hex1\E/, "object method k2: does not show other segments ok"; IPC::Shareable->clean_up_all; } IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/32-obj.t000644 000765 000024 00000002264 15207607745 015701 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(unique_glue assert_clean); my $t = 1; my $ok = 1; { package Dummy; sub new { my $d = { _first => undef, _second => undef, }; return bless $d => shift; } sub first { my $self = shift; $self->{_first} = shift if @_; return $self->{_first}; } sub second { my $self = shift; $self->{_second} = shift if @_; return $self->{_second}; } } tie my $d, 'IPC::Shareable', { key => unique_glue('obj'), create => 1, destroy => 'yes' , serializer => 'storable' }; $d = Dummy->new or undef $ok; is ref($d), 'Dummy', "shared var is a Dummy object ok"; is $d->first('first'), 'first', "shared obj first() returns ok"; is $d->second('second'), 'second', "shared obj second() returns ok"; is $d->first('foo'), 'foo', "shared obj first() returns ok, again"; is $d->second('bar'), 'bar', "shared obj second() returns ok, again"; IPC::Shareable::_end; assert_clean(unique_glue('obj')); done_testing(); IPC-Shareable-1.19/t/48-size_exceeded.t000644 000765 000024 00000002034 15207650136 017721 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process); my $k = tie my $sv, 'IPC::Shareable', { create => 1, destroy => 1, size => 1, serializer => 'storable', }; my $ok = eval { $sv = "more than one byte"; 1; }; is $ok, undef, "Overwriting the byte boundary size of an shm barfs ok"; like $@, qr/exceeds shared segment size/, "...and the error is sane"; (tied $sv)->clean_up_all; # JSON serializer: same size check fires in _encode_json { my $k2 = tie my $sv2, 'IPC::Shareable', { create => 1, destroy => 1, serializer => 'json', size => 1, }; my $ok2 = eval { $sv2 = 'x'; 1 }; is $ok2, undef, "json: croaks when encoded data exceeds segment size"; like $@, qr/exceeds shared segment size/, "json: ...and the error is sane"; $k2->clean_up_all; } IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/70-global_register.t000644 000765 000024 00000003301 15207655146 020264 0ustar00stevestaff000000 000000 use strict; use warnings; use Data::Dumper; use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue); use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); my $mod = 'IPC::Shareable'; # Bug 38: Ensure global register populates before access to the underlying # data { # Global register { my ($knot, %hv); { $knot = tie my %hv, $mod, { create => 1, key => unique_glue('testing123'), destroy => 1, }; my $id = $knot->seg->id; my $key = $knot->seg->key; my $dump = Dumper tied(%hv)->global_register; is grep(/\s+'$id'\s+/, $dump), 1, "Segment ID is in the global_register Dumper output ok"; is grep(/'_key' => $key/, $dump), 1, "So is the key in global_register output"; } is % hv, 0, "hash deleted after we go out of scope"; } # Process register { my ($knot, %hv); { $knot = tie my %hv, $mod, { create => 1, key => unique_glue('testing123'), destroy => 1, }; my $id = $knot->seg->id; my $key = $knot->seg->key; my $dump = Dumper tied(%hv)->process_register; is grep(/\s+'$id'\s+/, $dump), 1, "Segment ID is in the process_register Dumper output ok"; is grep(/'_key' => $key/, $dump), 1, "So is the key in process_register output"; } is % hv, 0, "hash deleted after we go out of scope"; } } IPC::Shareable->clean_up_all; IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/71-sysv_info.t000644 000765 000024 00000017057 15207650136 017147 0ustar00stevestaff000000 000000 use warnings; use strict; use Data::Dumper; use File::Temp qw(tempdir); use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process); # sysv_info() - class method { my $info = IPC::Shareable->sysv_info; if ($^O eq 'darwin' || $^O eq 'linux' || $^O eq 'freebsd' || $^O eq 'openbsd') { isnt $info, undef, "sysv_info() returns a value on $^O"; is ref $info, 'HASH', "...and it's a hash ref"; # shmmax, shmmni, shmall are always present on all supported platforms for my $key (qw(shmmax shmmni shmall)) { ok exists $info->{$key}, "...key '$key' exists"; like $info->{$key}, qr/^\d+$/, "...'$key' is an integer ($info->{$key})"; } # semmni is the max number of semaphore identifier sets. Reported # on every platform that exposes it via sysctl/procfs. ok exists $info->{semmni}, "...key 'semmni' exists on $^O"; like $info->{semmni}, qr/^\d+$/, "...'semmni' is an integer ($info->{semmni})"; if ($^O eq 'darwin') { # shmmin and shmseg come from sysctl and are always present on macOS for my $key (qw(shmmin shmseg)) { ok exists $info->{$key}, "...key '$key' exists on macOS"; like $info->{$key}, qr/^\d+$/, "...'$key' is an integer ($info->{$key})"; } } elsif ($^O eq 'freebsd') { # FreeBSD exposes the same five keys as macOS via sysctl kern.ipc for my $key (qw(shmmin shmseg)) { ok exists $info->{$key}, "...key '$key' exists on FreeBSD"; like $info->{$key}, qr/^\d+$/, "...'$key' is an integer ($info->{$key})"; } } elsif ($^O eq 'linux') { # shmmin is a kernel compile-time constant; not always exposed via procfs if (exists $info->{shmmin}) { like $info->{shmmin}, qr/^\d+$/, "...'shmmin' is an integer if present ($info->{shmmin})"; } else { pass "...'shmmin' not available via procfs on this kernel (ok)"; } } } else { is $info, undef, "sysv_info() returns undef on unsupported platform ($^O)"; } } # sysv_info() - object method { my $knot = tie my %hv, 'IPC::Shareable', { create => 1, destroy => 1 , serializer => 'storable' }; my $info = $knot->sysv_info; if ($^O eq 'darwin' || $^O eq 'linux' || $^O eq 'freebsd' || $^O eq 'openbsd') { isnt $info, undef, "sysv_info() called as object method returns a value"; is ref $info, 'HASH', "...and it's a hash ref"; for my $key (qw(shmmax shmmni shmall)) { ok exists $info->{$key}, "...key '$key' exists"; } } else { is $info, undef, "sysv_info() returns undef on unsupported platform ($^O)"; } # warn(Dumper $info); IPC::Shareable->clean_up_all; } # sysv_info() - class method and object method return identical data { my $knot = tie my %hv, 'IPC::Shareable', { create => 1, destroy => 1 , serializer => 'storable' }; if ($^O eq 'darwin' || $^O eq 'linux' || $^O eq 'freebsd' || $^O eq 'openbsd') { my $class_info = IPC::Shareable->sysv_info; my $object_info = $knot->sysv_info; is_deeply $class_info, $object_info, "Class method and object method return identical data"; } IPC::Shareable->clean_up_all; } assert_clean_process(); # ----------------------------------------------------------------------- # Linux branch - mocked via _proc_dir and local $^O # ----------------------------------------------------------------------- { my $tmpdir = tempdir(CLEANUP => 1); for my $key (qw(shmmax shmmin shmmni shmall)) { open my $fh, '>', "$tmpdir/$key" or die "Cannot create $tmpdir/$key: $!"; print $fh "65536\n"; close $fh; } open my $sem_fh, '>', "$tmpdir/sem" or die "Cannot create $tmpdir/sem: $!"; print $sem_fh "32000 1024000000 500 128\n"; # semmsl semmns semopm semmni close $sem_fh; my $info; { local $^O = 'linux'; $info = IPC::Shareable->sysv_info(_proc_dir => $tmpdir); } isnt $info, undef, "linux branch (mocked): sysv_info() returns a defined value"; is ref($info), 'HASH', "linux branch (mocked): return value is a hash ref"; for my $key (qw(shmmax shmmin shmmni shmall)) { is $info->{$key}, '65536', "linux branch (mocked): '$key' reads value from fake proc file"; } is $info->{semmsl}, '32000', "linux branch (mocked): semmsl from 1st field of /proc/sys/kernel/sem"; is $info->{semmns}, '1024000000', "linux branch (mocked): semmns from 2nd field"; is $info->{semopm}, '500', "linux branch (mocked): semopm from 3rd field"; is $info->{semmni}, '128', "linux branch (mocked): semmni from 4th field"; } # ----------------------------------------------------------------------- # FreeBSD branch - mocked via _sysctl_out and local $^O # ----------------------------------------------------------------------- { my $fake_out = join("\n", 'kern.ipc.shmmax: 65536', 'kern.ipc.shmmin: 1', 'kern.ipc.shmmni: 192', 'kern.ipc.shmseg: 128', 'kern.ipc.shmall: 131072', 'kern.ipc.semmni: 50', 'kern.ipc.semmns: 340', 'kern.ipc.semmsl: 340', 'kern.ipc.semopm: 100', 'kern.ipc.somethingelse: ignored', ); my $info; { local $^O = 'freebsd'; $info = IPC::Shareable->sysv_info(_sysctl_out => $fake_out); } isnt $info, undef, "freebsd branch (mocked): sysv_info() returns a defined value"; is ref($info), 'HASH', "freebsd branch (mocked): return value is a hash ref"; for my $key (qw(shmmax shmmin shmmni shmseg shmall semmni semmns semmsl semopm)) { ok exists $info->{$key}, "freebsd branch (mocked): '$key' key present"; like $info->{$key}, qr/^\d+$/, "freebsd branch (mocked): '$key' is an integer"; } ok !exists $info->{somethingelse}, "freebsd branch (mocked): non-shm/sem kern.ipc keys are filtered out"; } # ----------------------------------------------------------------------- # OpenBSD branch - mocked via _sysctl_out and local $^O # ----------------------------------------------------------------------- { my $fake_out = join("\n", 'kern.seminfo.semmni=10', 'kern.seminfo.semmns=60', 'kern.seminfo.semmsl=60', 'kern.shminfo.shmmax=33554432', 'kern.shminfo.shmmin=1', 'kern.shminfo.shmmni=128', 'kern.shminfo.shmall=8192', ); my $info; { local $^O = 'openbsd'; $info = IPC::Shareable->sysv_info(_sysctl_out => $fake_out); } isnt $info, undef, "openbsd branch (mocked): sysv_info() returns a defined value"; is ref($info), 'HASH', "openbsd branch (mocked): return value is a hash ref"; is $info->{semmni}, '10', "openbsd branch (mocked): semmni parsed"; is $info->{shmmax}, '33554432', "openbsd branch (mocked): shmmax parsed"; } # ----------------------------------------------------------------------- # Solaris branch - not implemented; sysv_info() returns undef # ----------------------------------------------------------------------- { my $info; { local $^O = 'solaris'; $info = IPC::Shareable->sysv_info; } is $info, undef, "solaris branch (mocked): sysv_info() returns undef (unsupported platform)"; } done_testing(); IPC-Shareable-1.19/t/PaxHeader/27-fetch_read_warn.t000644 000765 000024 00000000210 15222763263 022177 xustar00stevestaff000000 000000 30 mtime=1783359155.487092523 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/27-fetch_read_warn.t000644 000765 000024 00000012770 15222763263 020244 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable qw(:lock); IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue require_free_sem_sets); require_free_sem_sets(); use Test::SharedFork; # --- Unlocked FETCH warns when another knot holds LOCK_EX --- { my $k1 = tie my %h1, 'IPC::Shareable', { key => unique_glue('RW01'), create => 1, destroy => 1, enforced_read_locking => 1, violated_read_lock_warn => 1, serializer => 'storable', }; my $k2 = tie my %h2, 'IPC::Shareable', { key => unique_glue('RW01'), enforced_read_locking => 1, violated_read_lock_warn => 1, serializer => 'storable', }; $h1{a} = 10; pipe(my $r, my $w) or die "pipe: $!"; my $pid = fork; defined $pid or die "fork: $!"; if ($pid == 0) { close $r; $k1->lock(LOCK_EX); print $w "locked\n"; close $w; select(undef, undef, undef, 0.3); $k1->unlock; exit 0; } close $w; # Block until child signals it has acquired LOCK_EX my $line = <$r>; close $r; my $warned = 0; { local $SIG{__WARN__} = sub { my $w = shift; like $w, qr/exclusively locked/, "read warn - message mentions 'exclusively locked'"; like $w, qr/${\$k2->uuid}/, "read warn - message contains k2 UUID"; like $w, qr/${\$k2->seg->id}/, "read warn - message contains segment ID"; like $w, qr/stale/, "read warn - message mentions stale data risk"; like $w, qr/LOCK_SH/, "read warn - message suggests LOCK_SH"; $warned++; }; my $val = $h2{a}; } is $warned, 1, "read warn - exactly one warning emitted"; waitpid($pid, 0); # After child releases LOCK_EX, unlocked read must not warn { local $SIG{__WARN__} = sub { fail "read warn - unexpected warning after unlock: $_[0]" }; my $val = $h2{a}; } pass "read warn - no warning after LOCK_EX released"; } # --- No warning when enforced_read_locking is disabled --- { my $k1 = tie my %h1, 'IPC::Shareable', { key => unique_glue('RW02'), create => 1, destroy => 1, enforced_read_locking => 0, violated_read_lock_warn => 1, serializer => 'storable', }; my $k2 = tie my %h2, 'IPC::Shareable', { key => unique_glue('RW02'), enforced_read_locking => 0, violated_read_lock_warn => 1, serializer => 'storable', }; $h1{a} = 10; $k1->lock(LOCK_EX); { local $SIG{__WARN__} = sub { fail "no-enforced - unexpected warning: $_[0]" }; my $val = $h2{a}; } pass "no warning when enforced_read_locking is disabled"; $k1->unlock; } # --- No warning when violated_read_lock_warn is disabled --- { my $k1 = tie my %h1, 'IPC::Shareable', { key => unique_glue('RW03'), create => 1, destroy => 1, enforced_read_locking => 1, violated_read_lock_warn => 0, serializer => 'storable', }; my $k2 = tie my %h2, 'IPC::Shareable', { key => unique_glue('RW03'), enforced_read_locking => 1, violated_read_lock_warn => 0, serializer => 'storable', }; $h1{a} = 10; $k1->lock(LOCK_EX); { local $SIG{__WARN__} = sub { fail "no-warn - unexpected warning: $_[0]" }; my $val = $h2{a}; } pass "no warning when violated_read_lock_warn is disabled"; $k1->unlock; } # --- Both enforced_read_locking and violated_read_lock_warn disabled (degenerate) --- { my $k1 = tie my %h1, 'IPC::Shareable', { key => unique_glue('RW05'), create => 1, destroy => 1, enforced_read_locking => 0, violated_read_lock_warn => 0, serializer => 'storable', }; my $k2 = tie my %h2, 'IPC::Shareable', { key => unique_glue('RW05'), enforced_read_locking => 0, violated_read_lock_warn => 0, serializer => 'storable', }; $h1{a} = 10; $k1->lock(LOCK_EX); { local $SIG{__WARN__} = sub { fail "ER=0 VR=0 - unexpected warning: $_[0]" }; my $val = $h2{a}; } pass "ER=0 VR=0: no warning when both enforced_read_locking and violated_read_lock_warn are disabled"; $k1->unlock; } # --- Locked FETCH (LOCK_SH) does not warn --- { my $k1 = tie my %h1, 'IPC::Shareable', { key => unique_glue('RW04'), create => 1, destroy => 1, enforced_read_locking => 1, violated_read_lock_warn => 1, serializer => 'storable', }; my $k2 = tie my %h2, 'IPC::Shareable', { key => unique_glue('RW04'), enforced_read_locking => 1, violated_read_lock_warn => 1, serializer => 'storable', }; $h1{a} = 10; $k2->lock(LOCK_SH); { local $SIG{__WARN__} = sub { fail "locked-fetch - unexpected warning: $_[0]" }; my $val = $h2{a}; } pass "no warning on FETCH when knot holds LOCK_SH (uses _data cache)"; $k2->unlock; } IPC::Shareable::_end; assert_clean_process(); done_testing; IPC-Shareable-1.19/t/PaxHeader/91-pod_linkcheck.t000644 000765 000024 00000000210 15203172270 021651 xustar00stevestaff000000 000000 30 mtime=1779233976.185703577 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/91-pod_linkcheck.t000644 000765 000024 00000000464 15203172270 017713 0ustar00stevestaff000000 000000 use warnings; use strict; use Test::More; unless ( $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author test: RELEASE_TESTING not set" ); } eval "use Test::Pod::LinkCheck"; if ($@) { plan skip_all => 'Test::Pod::LinkCheck required for testing POD links'; } Test::Pod::LinkCheck->new->all_pod_ok; IPC-Shareable-1.19/t/PaxHeader/82-stale-ipc-reclaim.t000644 000765 000024 00000000210 15222763745 022365 xustar00stevestaff000000 000000 30 mtime=1783359461.875730845 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/82-stale-ipc-reclaim.t000644 000765 000024 00000011025 15222763745 020422 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Semaphore; use IPC::SysV qw(IPC_CREAT); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process require_free_sem_sets unique_glue); use IPC::Shareable; # A dedicated dist tag, so the clean_up_testing() calls in this file can only # ever match resources created here -- NOT the suite's own 'IPC::Shareable' # tagged ones (eg. t/00-base.t's live async_tests baseline pair, whose creator # process has exited and would otherwise be reclaimed as a stale pair). my $DIST = 'IPC::Shareable::T82'; IPC::Shareable->testing_set($DIST); require_free_sem_sets(); # Coverage for clean_up_testing()'s reclamation of stale IPC left by crashed # test runs. SysV resources persist until explicitly removed or reboot, so a # smoker host accumulates them run over run; on OpenBSD (kern.seminfo.semmni # defaults to 10) the stale semaphore sets eventually starve every semget() # into ENOSPC and every subsequent run FAILs. Three scenarios: # # 1. An orphaned testing-tagged semaphore set (segment already gone) is # reclaimed -- these were previously invisible: the reclaim scan walked # ipcs -m only, so a sem with no segment was never considered. # 2. An untagged orphan semaphore set is left alone: ownership cannot be # proven, and it could belong to any other application on the host. # 3. A testing-tagged segment+semaphore pair whose creator process has # exited (a crashed run's leftovers) is reclaimed whole. # --------------------------------------------------------------------------- # 1. Orphaned testing-tagged semaphore set (no segment) is reclaimed # --------------------------------------------------------------------------- { my $glue = unique_glue('orphan-marked-sem'); my $key_int = IPC::Shareable::_key_str_to_int($glue); my $target = IPC::Shareable::_testing_semaphore_key_hash($DIST); my $sem = IPC::Semaphore->new($key_int, 5, IPC_CREAT | 0666); ok defined $sem, 'marked orphan: created a bare 5-slot semaphore set (no segment)'; ok $sem->setval(IPC::Shareable::SEM_TESTING, $target), 'marked orphan: SEM_TESTING marker set'; my $removed = IPC::Shareable->clean_up_testing($DIST); cmp_ok $removed, '>=', 1, 'clean_up_testing() reports the reclaim'; my $still = IPC::Semaphore->new($key_int, 0, 0); ok ! defined $still, 'marked orphan: semaphore set was reclaimed'; # Safety net if a regression leaves it behind $still->remove if defined $still; } # --------------------------------------------------------------------------- # 2. Untagged orphan semaphore set is NOT touched (ownership unprovable) # --------------------------------------------------------------------------- { my $glue = unique_glue('orphan-unmarked-sem'); my $key_int = IPC::Shareable::_key_str_to_int($glue); my $sem = IPC::Semaphore->new($key_int, 4, IPC_CREAT | 0666); ok defined $sem, 'unmarked orphan: created a bare 4-slot semaphore set (no segment)'; IPC::Shareable->clean_up_testing($DIST); my $still = IPC::Semaphore->new($key_int, 0, 0); ok defined $still, 'unmarked orphan: left alone by clean_up_testing()'; $still->remove if defined $still; } # --------------------------------------------------------------------------- # 3. Testing-tagged pair with a dead creator is reclaimed whole # --------------------------------------------------------------------------- { my $glue = unique_glue('stale-marked-pair'); my $key_int = IPC::Shareable::_key_str_to_int($glue); my $pid = fork; die "Cannot fork: $!" if ! defined $pid; if ($pid == 0) { # Child: create a marked pair and exit WITHOUT cleaning up (no destroy # attribute), replicating what a crashed run leaves behind tie my %h, 'IPC::Shareable', { key => $glue, create => 1 }; $h{stale} = 1; exit 0; } waitpid($pid, 0); ok defined shmget($key_int, 0, 0), 'stale pair: segment persists after the creator exited'; ok defined IPC::Semaphore->new($key_int, 0, 0), 'stale pair: semaphore set persists after the creator exited'; IPC::Shareable->clean_up_testing($DIST); ok ! defined shmget($key_int, 0, 0), 'stale pair: segment reclaimed by clean_up_testing()'; my $leftover_sem = IPC::Semaphore->new($key_int, 0, 0); ok ! defined $leftover_sem, 'stale pair: semaphore set reclaimed by clean_up_testing()'; # Safety net $leftover_sem->remove if defined $leftover_sem; } IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/55-singleton_warn.t000644 000765 000024 00000001506 15207650136 020153 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process); # singleton no exit notice my ($proc, $warning); { local $SIG{__WARN__} = sub {$warning = shift;}; $proc = IPC::Shareable->singleton('LOCK', 1); is $proc, $$, "process ID $$ returned from singleton() ok on first call"; $proc = -1; is $proc, -1, "\$proc set to -1 ok"; $proc = IPC::Shareable->singleton('LOCK', 1); } END { is $proc, -1, "singleton() on second call doesn't return anything ok"; like $warning, qr/exited due to exclusive shared memory collision/, "singleton() warns if warn is enabled"; IPC::Shareable::_end; assert_clean_process(); done_testing; }; IPC-Shareable-1.19/t/80-SharedMem.t000644 000765 000024 00000022443 15207651432 016770 0ustar00stevestaff000000 000000 use warnings; use strict; use Config; use Data::Dumper; use IPC::Shareable; use IPC::SysV qw(IPC_CREAT IPC_EXCL); use Mock::Sub; use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(unique_glue); # Unique per-process keys so concurrent runs (eg. a parallel smoker) can't # collide on the same raw System V segment. SharedMem requires an integer key. my $key = IPC::Shareable::_key_str_to_int(unique_glue('shm80')); my $hex_key = sprintf '0x%08x', $key; my $mod = 'IPC::Shareable::SharedMem'; # new() { # croak on no key param { my $seg; my $ok = eval { $seg = $mod->new; 1; }; is $ok, undef, "new() equires a 'key' parameter with value"; like $@, qr/new\(\) requires a 'key'/, "...and error is sane"; } # croak on non-integer key { my $seg; my $ok = eval { $seg = $mod->new(key => 'aaaa'); 1; }; is $ok, undef, "'key' param must be integer"; like $@, qr/with an integer value/, "...and error is sane"; } # Success: check defaults { my $seg; my $ok = eval { $seg = $mod->new(key => $key, flags => IPC_CREAT); 1; }; is $ok, 1, "segment object created ok"; is ref $seg, 'IPC::Shareable::SharedMem', "object is of proper type ok"; is $seg->key, $key, "key attr set ok"; is $seg->size, 1024, "size attr default ok"; is $seg->flags, 950, "flags attr default ok"; is $seg->mode, 0666, "mode attr default ok"; is $seg->type, undef, "type defaults to undef ok"; like $seg->id, qr/^\d+$/, "id is an integer ok"; is $seg->remove, 1, "segment removed ok"; } } # size() { # Object already instantiated warning { my $warning; local $SIG{__WARN__} = sub { $warning = shift; }; my $seg = $mod->new(key => $key, flags => IPC_CREAT); $seg->size(2048); like $warning, qr/instantiated/, "size() warns that it can't be set after obj created"; is $seg->size, 1024, "...and it hasn't been changed ok"; is $seg->remove, 1, "seg cleaned up ok"; } # Invalid type { my $seg; my $ok = eval { $seg = $mod->new(key => $key, size => 'aaaa'); 1; }; is $ok, undef, "size() requires an integer"; like $@, qr/size\(\) requires an integer/, "...and error is sane"; } } # flags() { # Object already instantiated warning { my $warning; local $SIG{__WARN__} = sub { $warning = shift; }; my $seg = $mod->new(key => $key, flags => IPC_CREAT); $seg->flags(1024); like $warning, qr/instantiated/, "flags() warns that it can't be set after obj created"; is $seg->flags, 950, "...and it hasn't been changed ok"; is $seg->remove, 1, "seg cleaned up ok"; } } # mode() { # Object already instantiated warning { my $warning; local $SIG{__WARN__} = sub { $warning = shift; }; my $seg = $mod->new(key => $key, flags => IPC_CREAT); $seg->mode(0666); like $warning, qr/instantiated/, "mode() warns that it can't be set after obj created"; is $seg->mode, 0666, "...and it hasn't been changed ok"; is $seg->remove, 1, "seg cleaned up ok"; } # Successful change { my $seg = $mod->new(key => $key, flags => IPC_CREAT, mode => 0444); is $seg->mode, 0444, "mode() set ok in new"; is $seg->remove, 1, "seg cleaned up ok"; } } # type() { # Object already instantiated warning { my $warning; local $SIG{__WARN__} = sub { $warning = shift; }; my $seg = $mod->new(key => $key, flags => IPC_CREAT, type => 'TESTING'); $seg->type('HELLO'); like $warning, qr/instantiated/, "type() warns that it can't be set after obj created"; is $seg->type, 'TESTING', "...and it hasn't been changed ok"; is $seg->remove, 1, "seg cleaned up ok"; } } # id() { # Object already instantiated warning { my $warning; local $SIG{__WARN__} = sub { $warning = shift; }; my $seg = $mod->new(key => $key, flags => IPC_CREAT); my $created_id = $seg->id; $seg->id(9998); like $warning, qr/instantiated/, "id() warns that it can't be set after obj created"; is $seg->id, $created_id, "...and it hasn't been changed ok"; is $seg->remove, 1, "seg cleaned up ok"; } } # shmread() & shmwrite() { my $seg = $mod->new(key => $key, flags => IPC_CREAT); my $data = "blah"; is $seg->shmwrite($data), 1, "shmwrite() returns 1 on success"; is $seg->data, $data, "shmread() returns the proper data ok"; is $seg->remove, 1, "seg removed ok"; } # new() with a hex string key { my $seg = $mod->new(key => $hex_key, flags => IPC_CREAT); is ref($seg), 'IPC::Shareable::SharedMem', "new() with hex string key creates object ok"; is $seg->key, hex($hex_key), "new() with hex key: integer key stored correctly"; is $seg->remove, 1, "seg removed ok"; } # key() croak when called as setter after object is established { my $seg = $mod->new(key => $key, flags => IPC_CREAT); my $ok = eval { $seg->key(9999); 1 }; is $ok, undef, "key() croaks when set after object established"; like $@, qr/after object is already established/, "...and error message is correct"; is $seg->key, $key, "...and key is unchanged"; is $seg->remove, 1, "seg removed ok"; } # stat() returns undef when the underlying segment has been removed { my $seg = $mod->new(key => $key, flags => IPC_CREAT); $seg->remove; my $stat = $seg->stat; is $stat, undef, "stat() returns undef when segment has been removed"; } # remove() returns 0 on second call (segment already gone) { my $seg = $mod->new(key => $key, flags => IPC_CREAT); is $seg->remove, 1, "remove() returns 1 on first call"; is $seg->remove, 0, "remove() returns 0 on second call (segment already removed)"; } # stat { my $seg = $mod->new(key => $key, flags => IPC_CREAT, mode => 0644); my $data = "blah"; is $seg->shmwrite($data), 1, "shmwrite() returns 1 on success"; # printf("%d: %d\n", $seg->stat->uid, $seg->stat->ctime); is $seg->remove, 1, "seg removed ok"; } SKIP: { skip 'OpenBSD 64-bit shmid_ds tests require 64-bit Perl', 14 if $Config{ivsize} < 8; # OpenBSD 64-bit shmid_ds unpack template correctness # Construct a synthetic binary buffer with known values at the OpenBSD # 64-bit offsets (verified against offsetof() on OpenBSD 7.4 amd64). # # struct shmid_ds layout (104 bytes): # ipc_perm (32): uid(4) gid(4) cuid(4) cgid(4) mode(4) + 12 pad # segsz(4/int) lpid(4/pid_t) cpid(4/pid_t) nattch(2/shmatt_t) [pad 2] # atime(8/time_t) __shm_atimensec(8) # dtime(8/time_t) __shm_dtimensec(8) # ctime(8/time_t) __shm_ctimensec(8) + shm_internal(8) { my ($uid, $gid, $cuid, $cgid) = (1001, 1002, 1003, 1004); my $mode = 0644; my $segsz = 65536; my $lpid = 40001; my $cpid = 40002; my $nattch = 3; my ($atime, $dtime, $ctime) = (1748000000, 1748000001, 1748000002); my $synthetic = pack( 'L L L L L x[12] L l l S x[2] q x[8] q x[8] q x[16]', $uid, $gid, $cuid, $cgid, $mode, $segsz, $lpid, $cpid, $nattch, $atime, $dtime, $ctime ); my %vals; @vals{qw(uid gid cuid cgid mode segsz lpid cpid nattch atime dtime ctime)} = unpack('L L L L L x[12] L l l S x[2] q x[8] q x[8] q', $synthetic); is $vals{uid}, $uid, 'OpenBSD 64-bit stat: uid unpack correct'; is $vals{gid}, $gid, 'OpenBSD 64-bit stat: gid unpack correct'; is $vals{cuid}, $cuid, 'OpenBSD 64-bit stat: cuid unpack correct'; is $vals{cgid}, $cgid, 'OpenBSD 64-bit stat: cgid unpack correct'; is $vals{mode}, $mode, 'OpenBSD 64-bit stat: mode unpack correct'; is $vals{segsz}, $segsz, 'OpenBSD 64-bit stat: segsz unpack correct'; is $vals{lpid}, $lpid, 'OpenBSD 64-bit stat: lpid unpack correct'; is $vals{cpid}, $cpid, 'OpenBSD 64-bit stat: cpid unpack correct'; is $vals{nattch}, $nattch, 'OpenBSD 64-bit stat: nattch unpack correct'; is $vals{atime}, $atime, 'OpenBSD 64-bit stat: atime unpack correct'; is $vals{dtime}, $dtime, 'OpenBSD 64-bit stat: dtime unpack correct'; is $vals{ctime}, $ctime, 'OpenBSD 64-bit stat: ctime unpack correct'; my @seg_offsets = qw(uid gid cuid cgid mode segsz lpid cpid nattch atime dtime ctime); my $segsz_idx = 0; for (0..$#seg_offsets) { $segsz_idx = $_ if $seg_offsets[$_] eq 'segsz' } cmp_ok $vals{segsz}, '>=', 65536, "OpenBSD 64-bit stat: segsz (offset $segsz_idx in unpack) is >= 65536, not a garbage value"; } # Verify the pack template produces exactly 104 bytes (the real sizeof(shmid_ds)) { my $buf = pack('L L L L L x[12] L l l S x[2] q x[8] q x[8] q x[16]', 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12); is length($buf), 104, 'OpenBSD 64-bit: synthetic shmid_ds is 104 bytes'; } } # Scoped cleanup backstop: every segment this run created used $key, so confirm # none survive. Immune to other processes (unlike a global seg_count compare). is shmget($key, 0, 0), undef, "this run's SharedMem segment cleaned up ok"; done_testing(); IPC-Shareable-1.19/t/IPCShareableTest.pm000644 000765 000024 00000025110 15222763111 020116 0ustar00stevestaff000000 000000 package IPCShareableTest; use warnings; use strict; use Carp qw(croak); use Exporter qw(import); use Test::More; use IPC::Shareable; use IPC::Semaphore; # Below this many SysV semaphore *sets* (SEMMNI), a test that creates many tied # variables must release them as it goes rather than let them accumulate. Chosen # to catch tiny hosts (OpenBSD defaults to 10) while leaving roomy ones alone # (macOS ~87, Linux ~32000). use constant LOW_SEM_SETS => 32; # Default minimum of FREE semaphore sets a tie-using test file requires before # it will run (see require_free_sem_sets()). Chosen as a safe ceiling on any # single test file's peak concurrent tie count (root ties plus nested-ref # children), so that a file which starts is very unlikely to die ENOSPC # mid-run. On a healthy small host (OpenBSD semmni=10, nothing else running) # everything still runs; on one pre-wedged by stale sets, files skip cleanly # instead of failing. use constant FREE_SEM_SETS_NEEDED => 8; our @EXPORT_OK = qw( assert_clean assert_clean_process barrier_new barrier_release barrier_wait free_sem_sets live_seg_count low_sem_resources relieve_ipc_pressure require_free_sem_sets sem_set_limit tree_seg_count unique_glue ); # A token that is unique to this process and stable across fork() (it is # computed once, at load time, before any test forks). Embedding it in every # glue string gives each test run its own System V IPC keyspace, so concurrent # runs on the same host -- eg. a CPAN smoker testing many perls against the # same release at once -- can no longer collide on the same shared memory # segment or semaphore set. See evaluation.md for the failure analysis. our $TOKEN = sprintf '%d-%d', $$, int(rand(1_000_000)); # Assert that every shared memory segment AND semaphore set belonging to the # given run-scoped glue(s) has been cleaned up. Unlike the old global # seg_count()/sem_count() comparison, this only inspects resources keyed to # this run, so it is immune to unrelated IPC activity elsewhere on the host. sub assert_clean { my (@glues) = @_; if (! @glues) { croak "assert_clean() requires at least one glue string"; } my (@seg_leaks, @sem_leaks); for my $glue (@glues) { push @seg_leaks, $glue if tree_seg_count($glue) > 0; push @sem_leaks, $glue if _sem_exists($glue); } local $Test::Builder::Level = $Test::Builder::Level + 1; is scalar(@seg_leaks), 0, "all of this run's shm segments cleaned up ok" or diag "leaked shm segments for glue(s): @seg_leaks"; is scalar(@sem_leaks), 0, "all of this run's semaphore sets cleaned up ok" or diag "leaked semaphore sets for glue(s): @sem_leaks"; } # Process-scoped end-of-test cleanup assertion. Verifies that THIS process has # released every IPC::Shareable segment it created, via the module's own global # register. Immune to IPC activity from other processes (other smokers, or # parallel `prove -j` siblings), unlike the old global seg_count()/sem_count() # before/after comparison. One assertion: semaphore sets are created and # removed in lockstep with their segment, so an empty register implies none # leaked. NB: only tracks resources created through the normal tie/new path; a # test that pokes IPC::Shareable::SharedMem (or raw shm) directly should scope # its own check to the keys it used instead. sub assert_clean_process { my ($label) = @_; $label = "this process cleaned up all its IPC::Shareable segments" if ! defined $label; local $Test::Builder::Level = $Test::Builder::Level + 1; is live_seg_count(), 0, $label; } # Lost-wakeup-safe fork synchronisation, replacing the old SIGALRM/sleep # handshake where a signal delivered between the "unless $awake" test and # sleep() was lost and the sleeper blocked forever. A barrier is a single-use # one-way gate built on a pipe: the waiter blocks in readline() until the peer # writes a token, so the wakeup arrives as data (with EOF as a backstop) and # cannot be missed. Create one barrier per synchronisation point BEFORE fork(), # so both processes inherit its pipe ends. Same idiom as t/38-lsync.t. sub barrier_new { pipe(my $reader, my $writer) or croak "barrier_new() could not create pipe: $!"; return { reader => $reader, writer => $writer }; } # Release the peer blocked in barrier_wait() on the same barrier. This side # only signals, so it drops the read end, then writes a token and closes the # write end (which both delivers the token and yields EOF). sub barrier_release { my ($barrier) = @_; if (! defined $barrier) { croak "barrier_release() requires a \$barrier param"; } close $barrier->{reader}; print { $barrier->{writer} } "go\n"; close $barrier->{writer}; } # Block until the peer calls barrier_release() on the same barrier. This side # only waits, so it drops the write end first (otherwise it would hold the pipe # open and never see EOF), then reads until the peer signals. sub barrier_wait { my ($barrier) = @_; if (! defined $barrier) { croak "barrier_wait() requires a \$barrier param"; } close $barrier->{writer}; readline $barrier->{reader}; close $barrier->{reader}; } # Number of SysV semaphore sets still available on the host: the SEMMNI limit # minus the sets currently in use system-wide (by ANY process). Returns undef # when the limit cannot be determined. Unlike low_sem_resources() -- which # looks only at the LIMIT -- this accounts for sets already consumed, eg. by a # concurrent smoker or stale sets leaked by previously crashed runs, which is # what actually starves semget() into ENOSPC on wedged hosts. sub free_sem_sets { my $limit = sem_set_limit(); return undef if ! defined $limit; my $free = $limit - IPC::Shareable::sem_count(); return $free < 0 ? 0 : $free; } # Count of IPC::Shareable segments currently live and owned by THIS process # (a tied structure's root plus its nested-reference children), via the # module's own global register. Process-scoped, so it is immune to unrelated # IPC activity from other processes -- and unlike tree_seg_count() it works for # every serializer, including the binary 'storable' format whose child links # shm_segments() cannot parse back out of segment content. sub live_seg_count { return scalar keys %{ IPC::Shareable->global_register }; } my $_low_sem_cache; # True when the host has a small SysV semaphore-set budget (see LOW_SEM_SETS), # such that a test that creates many tied variables without releasing them # between steps would exhaust it. Each tie consumes one semaphore set, and on # OpenBSD the default kern.seminfo.semmni is only 10. An undeterminable limit is # treated as NOT constrained, so behaviour changes only on platforms we can # positively identify as small. Cached: the underlying probe runs once. sub low_sem_resources { return $_low_sem_cache if defined $_low_sem_cache; my $limit = sem_set_limit(); $_low_sem_cache = (defined $limit && $limit < LOW_SEM_SETS) ? 1 : 0; return $_low_sem_cache; } # Release every IPC::Shareable segment this process currently holds, but ONLY on # hosts with a small semaphore-set budget (see low_sem_resources()). A test that # creates many tied variables calls this between independent steps to stay under # the limit. On roomy platforms it is a no-op, so the test's behaviour there is # unchanged. sub relieve_ipc_pressure { IPC::Shareable::clean_up_all if low_sem_resources(); } # Skip the entire test file when the host does not have at least $needed free # SysV semaphore sets. Every tie consumes one set, so a file whose peak # concurrent tie count cannot be satisfied dies mid-run with "Could not create # semaphore set: No space left on device" (ENOSPC) -- the mass CPAN tester # FAIL mode on OpenBSD smokers (semmni=10) pre-wedged by stale sets from # previously crashed runs. Skipping is the honest grade there: the environment # cannot run the file, and a FAIL cascade (croaking mid-test and leaking yet # more IPC resources on the way down) helps nobody. No-op when the limit # cannot be determined. Call it before the first tie, after testing_set(). sub require_free_sem_sets { my ($needed) = @_; $needed = FREE_SEM_SETS_NEEDED if ! defined $needed; my $free = free_sem_sets(); return 1 if ! defined $free; if ($free < $needed) { plan skip_all => "insufficient free SysV semaphore sets " . "(free: $free, need: $needed)"; } return 1; } # Return the system-wide limit on SysV semaphore sets (SEMMNI) for the current # platform, or undef if it cannot be determined. Each IPC::Shareable tie consumes # one set, so this bounds how many live ties a process may hold at once. sub sem_set_limit { # Reuse the module's own cross-platform probe rather than re-deriving the # per-OS sysctl names here: sysv_info() reads kern.sysv (macOS), kern.ipc # (FreeBSD), kern.seminfo (OpenBSD), and /proc (Linux). Call it as a class # method (it shift()s its invocant) and trap its die-on-missing-sysctl. my $info = eval { IPC::Shareable->sysv_info }; return undef if ! $info; my $semmni = $info->{semmni}; return defined $semmni && $semmni =~ /^\d+$/ ? $semmni : undef; } # Number of live IPC::Shareable segments in this glue's segment tree (the root # plus any nested-reference child segments), as seen in the OS at the key # level. Used by assert_clean() to confirm real cleanup. Note: only the JSON # serializer records child links in a form shm_segments() can follow, so for # measuring a live storable structure's size use live_seg_count() instead. sub tree_seg_count { my ($glue) = @_; if (! defined $glue) { croak "tree_seg_count() requires a \$glue param"; } my $segs = IPC::Shareable::shm_segments($glue); return scalar keys %$segs; } # Turn a human-readable base name into a glue string that is unique to this # process. Deterministic within a process: unique_glue('foo') always returns # the same string, in both the parent and any forked child, so both sides of a # fork tie to the same key. sub unique_glue { my ($base) = @_; if (! defined $base) { croak "unique_glue() requires a \$base param"; } return "${base}-${TOKEN}"; } sub _sem_exists { my ($glue) = @_; if (! defined $glue) { croak "_sem_exists() requires a \$glue param"; } my $key = IPC::Shareable::_key_str_to_int($glue); # Attach-only (nsems => 0, flags => 0): returns an object if a semaphore # set already exists for this key, undef otherwise. This is the same probe # IPC::Shareable itself uses when removing a set. my $sem = IPC::Semaphore->new($key, 0, 0); return defined $sem ? 1 : 0; } 1; IPC-Shareable-1.19/t/PaxHeader/92-pod.t000644 000765 000024 00000000210 15203172270 017637 xustar00stevestaff000000 000000 30 mtime=1779233976.185871494 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/92-pod.t000644 000765 000024 00000000504 15203172270 015674 0ustar00stevestaff000000 000000 use strict; use warnings; use Test::More; unless ( $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author test: RELEASE_TESTING not set" ); } # Ensure a recent version of Test::Pod my $min_tp = 1.22; eval "use Test::Pod $min_tp"; plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; all_pod_files_ok(); IPC-Shareable-1.19/t/63-sig_child_ignore.t000644 000765 000024 00000000520 15207650136 020404 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process); my @command = ('date'); my $rc = system( @command ); is $rc, 0, "system() returns success ok after moving CHLD handler"; IPC::Shareable::_end; assert_clean_process(); done_testing(); IPC-Shareable-1.19/t/PaxHeader/23-lock_sh_enforcement.t000644 000765 000024 00000000210 15222763263 023067 xustar00stevestaff000000 000000 30 mtime=1783359155.486821148 57 LIBARCHIVE.xattr.com.apple.provenance=AQIAMUj2nFiKJo4 49 SCHILY.xattr.com.apple.provenance=1HX& IPC-Shareable-1.19/t/23-lock_sh_enforcement.t000644 000765 000024 00000016122 15222763263 021127 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable qw(:lock SEM_READERS SEM_WRITERS); IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue require_free_sem_sets); require_free_sem_sets(); # --- LOCK_SH blocks writes from other knots (enforced_write_locking) --- { my $k1 = tie my %h1, 'IPC::Shareable', { key => unique_glue('SLCK1'), create => 1, destroy => 1, enforced_write_locking => 1, enforced_read_locking => 1, serializer => 'storable', }; my $k2 = tie my %h2, 'IPC::Shareable', { key => unique_glue('SLCK1'), enforced_write_locking => 1, enforced_read_locking => 1, serializer => 'storable', }; $h1{a} = 10; is $h1{a}, 10, "LOCK_SH enforcement - initial value set ok"; # k1 acquires a shared read lock $k1->lock(LOCK_SH); is $k1->sem->getval(SEM_READERS), 1, "LOCK_SH enforcement - reader count is 1 after LOCK_SH"; is $k1->sem->getval(SEM_WRITERS), 0, "LOCK_SH enforcement - write lock is 0 after LOCK_SH"; # k2 attempts a write while k1 holds LOCK_SH -- must be blocked my $warned = 0; { local $SIG{__WARN__} = sub { my $w = shift; like $w, qr/active readers/, "LOCK_SH enforcement - blocked write warns 'active readers'"; like $w, qr/${\$k2->uuid}/, "LOCK_SH enforcement - warning contains k2 UUID"; $warned++; }; my $result = $h2{a} = 99; } is $warned, 1, "LOCK_SH enforcement - exactly one warning emitted"; is $h1{a}, 10, "LOCK_SH enforcement - k2 write blocked while k1 holds LOCK_SH"; $k1->unlock; is $k1->sem->getval(SEM_READERS), 0, "LOCK_SH enforcement - reader count is 0 after unlock"; # After k1 releases LOCK_SH, k2 can write freely $h2{a} = 99; is $h2{a}, 99, "LOCK_SH enforcement - k2 write succeeds after k1 releases LOCK_SH"; } # --- LOCK_SH holder itself cannot write (must upgrade to LOCK_EX) --- { my $k1 = tie my %h1, 'IPC::Shareable', { key => unique_glue('SLCK2'), create => 1, destroy => 1, enforced_write_locking => 1, enforced_read_locking => 1, serializer => 'storable', }; $h1{a} = 10; is $h1{a}, 10, "LOCK_SH self-write - initial value set ok"; $k1->lock(LOCK_SH); # k1 holds LOCK_SH and tries to write itself -- must be blocked my $warned = 0; { local $SIG{__WARN__} = sub { my $w = shift; like $w, qr/active readers/, "LOCK_SH self-write - blocked write warns 'active readers'"; like $w, qr/${\$k1->uuid}/, "LOCK_SH self-write - warning contains k1 UUID"; $warned++; }; $h1{a} = 99; } is $warned, 1, "LOCK_SH self-write - exactly one warning emitted"; is $h1{a}, 10, "LOCK_SH self-write - write blocked while holding own LOCK_SH"; $k1->unlock; # After upgrading to LOCK_EX, write succeeds $k1->lock(LOCK_EX); $h1{a} = 99; $k1->unlock; is $h1{a}, 99, "LOCK_SH self-write - write succeeds after upgrading to LOCK_EX"; } # --- violated_write_lock_warn fires with 'active readers' message --- { my $k1 = tie my %h1, 'IPC::Shareable', { key => unique_glue('SLCK3'), create => 1, destroy => 1, enforced_write_locking => 1, enforced_read_locking => 1, serializer => 'storable', }; my $k2 = tie my %h2, 'IPC::Shareable', { key => unique_glue('SLCK3'), enforced_write_locking => 1, enforced_read_locking => 1, violated_write_lock_warn => 1, serializer => 'storable', }; $h1{a} = 10; $k1->lock(LOCK_SH); my $warned = 0; local $SIG{__WARN__} = sub { my $w = shift; my $uuid = $k2->uuid; my $seg_id = $k2->seg->id; like $w, qr/active readers/, "violated_write_lock_warn - message mentions 'active readers'"; like $w, qr/$uuid/, "violated_write_lock_warn - message contains UUID"; like $w, qr/$seg_id/, "violated_write_lock_warn - message contains segment ID"; $warned++; }; $h2{a} = 99; is $warned, 1, "violated_write_lock_warn - warning fired exactly once"; $k1->unlock; # After unlock warning should not fire again { local $SIG{__WARN__} = sub { fail "violated_write_lock_warn - unexpected warning after unlock: $_[0]" }; $h2{a} = 99; } is $h2{a}, 99, "violated_write_lock_warn - write succeeds after readers gone"; } # --- LOCK_EX blocking still works (regression) --- { my $k1 = tie my %h1, 'IPC::Shareable', { key => unique_glue('SLCK4'), create => 1, destroy => 1, enforced_write_locking => 1, enforced_read_locking => 1, serializer => 'storable', }; my $k2 = tie my %h2, 'IPC::Shareable', { key => unique_glue('SLCK4'), enforced_write_locking => 1, enforced_read_locking => 1, serializer => 'storable', }; $h1{a} = 10; $k1->lock(LOCK_EX); my $warned = 0; { local $SIG{__WARN__} = sub { my $w = shift; like $w, qr/exclusively locked/, "LOCK_EX regression - blocked write warns 'exclusively locked'"; like $w, qr/${\$k2->uuid}/, "LOCK_EX regression - warning contains k2 UUID"; $warned++; }; $h2{a} = 99; } is $warned, 1, "LOCK_EX regression - exactly one warning emitted"; is $h1{a}, 10, "LOCK_EX regression - k2 write blocked while k1 holds LOCK_EX"; $k1->unlock; $h2{a} = 99; is $h2{a}, 99, "LOCK_EX regression - k2 write succeeds after k1 unlocks"; } # --- Both write-locking flags disabled: write succeeds silently while # another knot holds LOCK_EX (no warning, no block) --- { my $k1 = tie my %h1, 'IPC::Shareable', { key => unique_glue('SLCK5'), create => 1, destroy => 1, enforced_write_locking => 0, violated_write_lock_warn => 0, enforced_read_locking => 0, violated_read_lock_warn => 0, serializer => 'storable', }; my $k2 = tie my %h2, 'IPC::Shareable', { key => unique_glue('SLCK5'), enforced_write_locking => 0, violated_write_lock_warn => 0, enforced_read_locking => 0, violated_read_lock_warn => 0, serializer => 'storable', }; $h1{a} = 10; $k1->lock(LOCK_EX); { local $SIG{__WARN__} = sub { fail "EW=0 VW=0: unexpected warning: $_[0]" }; $h2{a} = 99; } pass "EW=0 VW=0: no warning when both write-locking flags are disabled"; is $h2{a}, 99, "EW=0 VW=0: write succeeds while another knot holds LOCK_EX"; $k1->unlock; } IPC::Shareable::_end; assert_clean_process(); done_testing; IPC-Shareable-1.19/t/52-graceful.t000644 000765 000024 00000002774 15207655146 016725 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; IPC::Shareable->testing_set('IPC::Shareable'); use Test::More; use FindBin; use lib $FindBin::Bin; use IPCShareableTest qw(assert_clean_process unique_glue); # non-graceful { tie my $sv, 'IPC::Shareable', { key => unique_glue('lock'), create => 1, exclusive => 1, destroy => 1, serializer => 'storable', }; my $catch = eval { tie my $sv2, 'IPC::Shareable', { key => unique_glue('lock'), create => 1, exclusive => 1, destroy => 1, serializer => 'storable', }; 1; }; is $catch, undef, "without 'graceful', we croak if two attemps made on same exclusive seg"; like $@, qr/using exclusive/, "...and error message is sane"; } # graceful my $catch; { tie my $sv, 'IPC::Shareable', { key => unique_glue('DONE'), create => 1, exclusive => 1, graceful => 1, destroy => 1, serializer => 'storable', }; tie my $sv2, 'IPC::Shareable', { key => unique_glue('DONE'), create => 1, exclusive => 1, graceful => 1, destroy => 1, serializer => 'storable', }; } END { is $@, '', "with 'graceful', we silently exit if two attempts made on same exclusive seg"; IPC::Shareable::_end; assert_clean_process(); done_testing; }; IPC-Shareable-1.19/docs/PaxHeader/Shared Memory Configuration.txt000644 000765 000024 00000004433 15201226514 025127 xustar00stevestaff000000 000000 30 mtime=1778724172.875480566 127 LIBARCHIVE.xattr.com.apple.metadata:kMDItemTextContentLanguage=YnBsaXN0MDBSZW4IAAAAAAAAAQEAAAAAAAAAAQAAAAAAAAAAAAAAAAAAAAs 108 SCHILY.xattr.com.apple.metadata:kMDItemTextContentLanguage=bplist00Ren 123 LIBARCHIVE.xattr.com.apple.metadata:kMDItemKeyphraseVersion=YnBsaXN0MDAQDAgAAAAAAAABAQAAAAAAAAABAAAAAAAAAAAAAAAAAAAACg 104 SCHILY.xattr.com.apple.metadata:kMDItemKeyphraseVersion=bplist00  674 LIBARCHIVE.xattr.com.apple.metadata:kMDItemKeyphraseLabels=YnBsaXN0MDCvEBABAgMEBQYHCAkKCwwNDg8QXXNoYXJlZCBtZW1vcnlfEBttYXggYW1vdW50IG9mIHNoYXJlZCBtZW1vcnlfEBJydW5uaW5nIHVuaXQgdGVzdHNfEBVjb3VwbGUgZG96ZW4gc2VnbWVudHNfEA9hbGxvd2luZyBhY2Nlc3NaYWRkaW5nIG5ld18QHm1pbiBzaGFyZWQgbWVtb3J5IHNlZ21lbnQgc2l6ZV8QJ21heCBudW1iZXIgb2Ygc2hhcmVkIG1lbW9yeSBpZGVudGlmaWVyc18QHm1heCBzaGFyZWQgbWVtb3J5IHNlZ21lbnQgc2l6ZV8QJm1heCBzaGFyZWQgbWVtb3J5IHNlZ21lbnRzIHBlciBwcm9jZXNzW21hY29zIHNlZW1zXxAUc2VnbWVudHMgcGVyIHByb2Nlc3Ncc2VnbWVudCBzaXplXxAUZG9jdHlwZSBwbGlzdCBwdWJsaWNdbGVhayBzZWdtZW50c1t4bWwgdmVyc2lvbgAIABsAKQBHAFwAdACGAJEAsgDcAP0BJgEyAUkBVgFtAXsAAAAAAAACAQAAAAAAAAARAAAAAAAAAAAAAAAAAAABhw 517 SCHILY.xattr.com.apple.metadata:kMDItemKeyphraseLabels=bplist00 ]shared memory_max amount of shared memory_running unit tests_couple dozen segments_allowing accessZadding new_min shared memory segment size_'max number of shared memory identifiers_max shared memory segment size_&max shared memory segments per process[macos seems_segments per process\segment size_doctype plist public]leak segments[xml version)G\t&2IVm{ 363 LIBARCHIVE.xattr.com.apple.metadata:kMDItemKeyphraseConfidences=YnBsaXN0MDCvEBABAgMEBQYHCAkKCwwNDg8QIz/2zluwvVPOIz/r/918xTlAIz/qnrkW+847Iz/l2xG0Sw3QIz/YnE+3AwwAIz/VXwA9TmF4Iz/TxbiQe1nzIz/RFBrEh2IVIz/OPTsSh2MaIz/NJYFxli1rIz+mLVfZih5AI7+I+xvnWNQAI7+Uw3AAAAAAI7+lH6dl+c2rI7/Vrl4AAAAAI7/gfdQu4u1oCBskLTY/SFFaY2x1foeQmaIAAAAAAAABAQAAAAAAAAARAAAAAAAAAAAAAAAAAAAAqw 285 SCHILY.xattr.com.apple.metadata:kMDItemKeyphraseConfidences=bplist00 #?[S#?|9@#?ꞹ;#?K #?؜O #?_=Nax#?Ÿ{Y#?ćb#?=;c#?%q-k#?-Wي@#X#p#eͫ#ծ^#}.h$-6?HQZclu~ IPC-Shareable-1.19/docs/Shared Memory Configuration.txt000644 000765 000024 00000004632 15201226514 023157 0ustar00stevestaff000000 000000 MacOS seems to be very greedy when allowing access to shared memory. By default, it has the following: shmmax: 4194304 (max shared memory segment size) shmmin: 1 (min shared memory segment size) shmmni: 32 (max number of shared memory identifiers) shmseg: 8 (max shared memory segments per process) shmall: 1024 (max amount of shared memory in pages) 4MB for a segment size, with only 8 segments per process and globally, just 32. That makes things very difficult when running unit tests for IPC::Shareable, as there could be a couple dozen segments in use at any time, and when adding new features, they are bound to leak segments all over the place until things are stabilized and polished. On my MacOS Tahoe system, I add the following data to the "/Library/LaunchDaemons/com.local.shmem.plist" file, then set it to root/wheel, with 644 perms. Label com.local.shmem ProgramArguments /usr/local/bin/set-shm.sh RunAtLoad StandardOutPath /var/log/com.local.shmem.out StandardErrorPath /var/log/com.local.shmem.err Then in /usr/local/bin/set-shm.sh, I have (with root:wheel, 755): #!/bin/sh /usr/sbin/sysctl -w kern.sysv.shmmni=128 /usr/sbin/sysctl -w kern.sysv.shmmax=4194304 /usr/sbin/sysctl -w kern.sysv.shmseg=256 /usr/sbin/sysctl -w kern.sysv.shmall=262144 /usr/sbin/sysctl -w kern.sysv.shmmin=1 You can attempt to load it live time: sudo launchctl kickstart -k system/com.local.shmem If you get a permissions error, you may have to disable System Integrity Protection: - Shutdown - Hold power button to power up and go into Recovery->Options->Utilities->Terminal - Run "csrutil disable" - Reboot into normal mode - Run "sudo launchctl kickstart -k system/com.local.shmem" - If successful, reboot into recovery again, and: - Run "csrutil enable" - Reboot normally The SYSV settings should have taken now.