IPC-Shareable-1.13/000755 000765 000024 00000000000 14321403012 014214 5ustar00stevestaff000000 000000 IPC-Shareable-1.13/DISCLAIMER000644 000765 000024 00000002324 14210441431 015560 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.13/Changes000644 000765 000024 00000027537 14321402767 015545 0ustar00stevestaff000000 000000 Revision history for Perl extension IPC::Shareable. 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.13/ipc.pl000644 000765 000024 00000000132 14321402741 015330 0ustar00stevestaff000000 000000 use warnings; use strict; use feature 'say'; use Script::Singleton warn => 1; sleep 10; IPC-Shareable-1.13/MANIFEST000644 000765 000024 00000002453 14321403012 015351 0ustar00stevestaff000000 000000 benchmarks/bench_changes.pl benchmarks/bench_results.txt benchmarks/sereal_vs_storable_vs_json_without_ipc.pl benchmarks/shared.pl benchmarks/storable_vs_json.pl Changes COPYING CREDITS DISCLAIMER 'docs/Shared Memory Configuration.txt' examples/new.pl ipc.pl lib/IPC/Shareable.pm lib/IPC/Shareable/SharedMem.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP README t/00-base.t t/02-create.t t/04-key.t t/05-sv.t t/07-new.t t/08-new_tied_obj.t t/10-av.t t/15-hv.t t/17-attributes.t t/20-ref.t t/25-ipc.t t/30-lock_operation.t t/31-lock_semaphore.t t/35-clean.t t/36-ipcav.t t/38-ipchv.t t/40-ipcref.t t/45-obj.t t/50-ipcobj.t t/55-lsync.t t/60-tied.t t/61-seg_sem.t t/63-nested_segs_tidy.t t/64-nested_segs_untidy.t t/65-seg_size.t t/66-size_exceeded.t t/67-exhaust_shm_slots.t t/75-graceful.t t/76-singleton.t t/77-singleton_warn.t t/78-singleton_class.t t/80-exceptions.t t/81-fork_dup_rand_keys.t t/82-sig_child_ignore.t t/83-clean_protected.t t/90-pod_coverage.t t/91-pod_linkcheck.t t/92-pod.t t/93-manifest.t t/99-end.t testing/new_one.pl testing/new_two.pl testing/one_deep_hash.pl testing/sharelite_with_sereal.pl testing/two_deep_hash.pl META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) IPC-Shareable-1.13/docs/000755 000765 000024 00000000000 14321403012 015144 5ustar00stevestaff000000 000000 IPC-Shareable-1.13/t/000755 000765 000024 00000000000 14321403012 014457 5ustar00stevestaff000000 000000 IPC-Shareable-1.13/README000644 000765 000024 00000050763 14210441431 015113 0ustar00stevestaff000000 000000 NAME IPC::Shareable - Use shared memory backed variables across processes SYNOPSIS use IPC::Shareable qw(:lock); my $href = IPC::Shareable->new(%options); # ...or tie SCALAR, 'IPC::Shareable', OPTIONS; tie ARRAY, 'IPC::Shareable', OPTIONS; tie HASH, 'IPC::Shareable', OPTIONS; (tied VARIABLE)->lock; (tied VARIABLE)->unlock; (tied VARIABLE)->lock(LOCK_SH|LOCK_NB) or print "Resource unavailable\n"; my $segment = (tied VARIABLE)->seg; my $semaphore = (tied VARIABLE)->sem; (tied VARIABLE)->remove; IPC::Shareable->clean_up; IPC::Shareable->clean_up_all; # Ensure only one instance of a script can be run at any time IPC::Shareable->singleton('UNIQUE SCRIPT LOCK STRING'); 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. The association between variables in distinct processes is provided by GLUE (aka "key"). This is any arbitrary string or integer that serves as a common identifier for data across process space. Hence the statement: tie my $scalar, 'IPC::Shareable', { key => 'GLUE STRING', create => 1 }; ...in program one and the statement tie my $variable, 'IPC::Shareable', { key => 'GLUE STRING' }; ...in program two will create and bind $scalar the shared memory in program one and bind it to $variable 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 (the exact value is system-dependent). The bound data structures are all linearized (using Raphael Manfredi's Storable module or optionally JSON) 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. OPTIONS Options are specified by passing a reference to a hash as the third argument to the tie() function that enchants a variable. The following fields are recognized in the options hash: key key 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 IPC_PRIVATE. This default key will not allow sharing of the variable between processes. Default: IPC_PRIVATE create create is used to control whether the process creates a new shared memory segment or not. If create is set to a true value, IPC::Shareable will create a new binding associated with GLUE as needed. If create is false, IPC::Shareable 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 croak(). Defult: false exclusive If exclusive field is set to a true value, we will croak() if the data binding associated with GLUE already exists. If set to a false value, calls to tie() will succeed even if a shared memory segment associated with GLUE already exists. See "graceful" for a silent, non-exception exit if a second process attempts to obtain an in-use exclusive segment. Default: false graceful If exclusive is set to a true value, we normally croak() if a second process attempts to obtain the same shared memory segment. Set graceful to true and we'll exit silently and gracefully. This option does nothing if exclusive isn't set. Useful for ensuring only a single process is running at a time. Default: false warn When set to a true value, graceful will output a warning if there are process collisions. Default: false mode The mode 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 0666 is world readable, 0600 is readable only by the effective UID of the process creating the shared variable, etc. Default: 0666 (world read and writeable) size This field may be used to specify the size of the shared memory segment allocated. The maximum size we allow by default is ~1GB. See the "limit" option to override this default. Default: IPC::Shareable::SHM_BUFSIZ() (ie. 65536) 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 croak() if a size specified is larger than the maximum. If it's set to a false value, we'll croak() if you send in a size larger than the total system RAM. Default: true 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 (gracefully)[1]. 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. Default: false tidy For long running processes, set this to a true value to clean up unneeded segments from nested data structures. Comes with a slight performance hit. Default: false serializer By default, we use Storable as the data serializer when writing to or reading from the shared memory segments we create. For cross-platform and cross-language purposes, you can optionally use JSON for this task. Send in either json or storable as the value to use the respective serializer. Default: storable Default Option Values Default values for options are: key => IPC_PRIVATE, create => 0, exclusive => 0, mode => 0, size => IPC::Shareable::SHM_BUFSIZ(), limit => 1, destroy => 0, graceful => 0, warn => 0, tidy => 0, serializer => 'storable', METHODS new Instantiates and returns a reference to a hash backed by shared memory. Parameters: Hash, Optional: See the "OPTIONS" section for a list of all available options. Most often, you'll want to send in the key, create and destroy options. It is possible to get a reference to an array or scalar as well. Simply send in either var = > 'ARRAY' or var => 'SCALAR' to do so. Return: A reference to a hash (or array or scalar) which is backed by shared memory. 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: false ipcs Returns the number of instantiated shared memory segments that currently exist on the system. Return: Integer spawn(%opts) Spawns a forked process running in the background that holds the shared memory segments backing your variable open. Parameters: Paremters are sent in as a hash. key => $glue Mandatory, String/Integer: The glue that you will be accessing your data as. mode => 0666 Optional, Integer: The read/write permissions on the variable. Defaults to 0666. Example: use IPC::Shareable; # The following line sets things up and returns IPC::Shareable->spawn(key => 'GLUE STRING'); Now, either within the same script, or any other script on the system, your data will be available at the key/glue GLUE STRING. Call unspawn() to remove it. unspawn($key, $destroy) This method will kill off the background process created with spawn(). Parameters: $key Mandatory, String/Integer: The glue (aka key) used in the call to spawn(). $destroy Optional, Bool. If set to a true value, we will remove all semaphores and memory segments related to your data, thus removing the data in its entirety. If not set to a true value, we'll leave the memory segments in place, and you'll be able to re-attach to the data at any time. Defaults to false (0). lock($flags) Obtains a lock on the shared memory. $flags specifies the type of lock to acquire. If $flags is not specified, an exclusive read/write lock is obtained. Acceptable values for $flags are the same as for the flock() system call. Returns true on success, and undef on error. For non-blocking calls (see below), the method returns 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 0 if it would have had to wait to obtain the lock. Note that 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 flock() call for details. Locks are inherited through forks, which means that two processes actually can possess an exclusive lock at the same time. Don't do that. The constants LOCK_EX, LOCK_SH, LOCK_NB, and LOCK_UN 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 flock constants available in the Fcntl module. See "LOCKING" for further details. unlock Removes a lock. Takes no parameters, returns true on success. This is equivalent of calling shlock(LOCK_UN). See "LOCKING" for further details. seg Called on either the tied variable or the tie object, returns the shared memory segment object currently in use. sem Called on either the tied variable or the tie object, returns the semaphore object related to the memory segment currently in use. attributes Retrieves the list of attributes that drive the IPC::Shareable object. Parameters: $attribute Optional, String: The name of the attribute. If sent in, we'll return the value of this specific attribute. Returns undef if the attribute isn't found. Returns: A hash reference of all attributes if $attributes isn't sent in, the value of the specific attribute if it is. global_register Returns a hash reference of hashes of all in-use shared memory segments across all processes. The key is the memory segment ID, and the value is the segment and semaphore objects. process_register Returns a hash reference of hashes of all in-use shared memory segments created by the calling process. The key is the memory segment ID, and the value is the segment and semaphore objects. LOCKING IPC::Shareable provides methods to implement application-level advisory locking of the shared data structures. These methods are called shlock() and shunlock(). To use them you must first get the object underlying the tied variable, either by saving the return value of the original call to tie() or by using the built-in tied() function. To lock and subsequently unlock a variable, do this: my $knot = tie my %hash, 'IPC::Shareable', { %options }; $knot->lock; $hash{a} = 'foo'; $knot->unlock; or equivalently, if you've decided to throw away the return of tie(): tie my %hash, 'IPC::Shareable', { %options }; tied(%hash)->lock; $hash{a} = 'foo'; tied(%hash)->unlock; This will place an exclusive lock on the data of $scalar. You can also get shared locks or attempt to get a lock without blocking. IPC::Shareable makes the constants LOCK_EX, LOCK_SH, LOCK_UN, and LOCK_NB exportable to your address space with the export tags :lock, :flock, or :all. The values should be the same as the standard flock option arguments. if (tied(%hash)->lock(LOCK_SH|LOCK_NB)){ print "The value is $hash{a}\n"; tied(%hash)->unlock; } else { print "Another process has an exlusive lock.\n"; } If no argument is provided to lock, it defaults to LOCK_EX. There are some pitfalls regarding locking and signals about which you should make yourself aware; these are discussed in "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. REFERENCES Although references can reside within a shared data structure, the tied variable can not be a reference itself. DESTRUCTION perl(1) will destroy the object underlying a tied variable when then tied variable goes out of scope. Unfortunately for IPC::Shareable, this may not be desirable: other processes may still need a handle on the relevant shared memory segment. IPC::Shareable therefore provides several options to control the timing of removal of shared memory segments. destroy Option As described in "OPTIONS", specifying the destroy option when tie()ing a variable coerces IPC::Shareable to remove the underlying shared memory segment when the process calling tie() exits gracefully. NOTE: The destruction is handled in an END block. Only those memory segments that are tied to the current process will be removed. remove tied($var)->remove; # or $knot->remove; Calling remove() on the object underlying a tie()d variable removes the associated shared memory segments. The segment is removed irrespective of whether it has the destroy option set or not and irrespective of whether the calling process created the segment. clean_up IPC::Shareable->clean_up; # or tied($var)->clean_up; # or $knot->clean_up; This is a class method that provokes IPC::Shareable to remove all shared memory segments created by the process. Segments not created by the calling process are not removed. 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 IPC::Shareable to remove all shared memory segments encountered by the process. Segments are removed even if they were not created by the calling process. RETURN VALUES Calls to tie() that try to implement IPC::Shareable will return an instance of IPC::Shareable on success, and undef otherwise. AUTHOR Benjamin Sugars MAINTAINED BY Steve Bertrand NOTES Footnotes from the above sections 1. If the process has been smoked by an untrapped signal, the binding will remain in shared memory. If you're cautious, you might try $SIG{INT} = \&catch_int; sub catch_int { die; } ... tie $variable, IPC::Shareable, { key => 'GLUE', create => 1, 'destroy' => 1 }; which will at least clean up after your user hits CTRL-C because IPC::Shareable's END method will be called. Or, maybe you'd like to leave the binding in shared memory, so subsequent process can recover the data... General Notes o When using lock() to lock a variable, be careful to guard against signals. Under normal circumstances, IPC::Shareable's END method unlocks any locked variables when the process exits. However, if an untrapped signal is received while a process holds an exclusive lock, DESTROY will not be called and the lock may be maintained even though the process has exited. If this scares you, you might be better off implementing your own locking methods. One advantage of using flock on some known file instead of the locking implemented with semaphores in IPC::Shareable is that when a process dies, it automatically releases any locks. This only happens with IPC::Shareable if the process dies gracefully. The alternative is to attempt to account for every possible calamitous ending for your process (robust signal handling in Perl is a source of much debate, though it usually works just fine) or to become familiar with your system's tools for removing shared memory and semaphores. This concern should be balanced against the significant performance improvements you can gain for larger data structures by using the locking mechanism implemented in IPC::Shareable. o There is a program called ipcs(1/8) (and ipcrm(1/8)) that is available on at least Solaris and Linux that might be useful for cleaning moribund shared memory segments or semaphore sets produced by bugs in either IPC::Shareable or applications using it. Examples: # List all semaphores and memory segments in use on the system ipcs -a # List all memory segments and semaphores along with each one's associated process ID ipcs -ap # List just the shared memory segments ipcs -m # List the details of an individual memory segment ipcs -i 12345678 # Remove *all* semaphores and memory segments ipcrm -a o This version of IPC::Shareable does not understand the format of shared memory segments created by versions prior to 0.60. If you try to tie to such segments, you will get an error. The only work around is to clear the shared memory segments and start with a fresh set. 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 IPC::Shareable, but we attempt this optimization if you do not). The fetch/thaw operation is performed when the first key is accessed. Subsequent key and 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. 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 SEE ALSO perltie, Storable, shmget, ipcs, ipcrm and other SysV IPC manual pages. IPC-Shareable-1.13/testing/000755 000765 000024 00000000000 14321403012 015671 5ustar00stevestaff000000 000000 IPC-Shareable-1.13/COPYING000644 000765 000024 00000043076 14210441431 015265 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.13/MANIFEST.SKIP000644 000765 000024 00000000504 14210441431 016115 0ustar00stevestaff000000 000000 ^images/ .bs$ .c$ .sh$ \.o$ ~$ ^blib/ ^pm_to_blib/ \.old$ \.orig$ \.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/ IPC-Shareable-1.13/examples/000755 000765 000024 00000000000 14321403012 016032 5ustar00stevestaff000000 000000 IPC-Shareable-1.13/benchmarks/000755 000765 000024 00000000000 14321403012 016331 5ustar00stevestaff000000 000000 IPC-Shareable-1.13/META.yml000644 000765 000024 00000001514 14321403012 015466 0ustar00stevestaff000000 000000 --- abstract: 'Use shared memory backed variables across processes' author: - 'Steve Bertrand ' build_requires: IPC::Semaphore: '0' Mock::Sub: '0' Test::More: '0' Test::SharedFork: '0.35' configure_requires: ExtUtils::MakeMaker: '6.72' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.44, 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: JSON: '0' Scalar::Util: '0' Storable: '0.607' String::CRC32: '0' perl: '5.01' resources: bugtracker: https://github.com/stevieb9/ipc-shareable/issues repository: https://github.com/stevieb9/ipc-shareable.git version: '1.13' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' IPC-Shareable-1.13/lib/000755 000765 000024 00000000000 14321403012 014762 5ustar00stevestaff000000 000000 IPC-Shareable-1.13/Makefile.PL000644 000765 000024 00000002364 14210473562 016211 0ustar00stevestaff000000 000000 use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'IPC::Shareable', VERSION_FROM => 'lib/IPC/Shareable.pm', ($] >= 5.005 ? (ABSTRACT_FROM => 'lib/IPC/Shareable.pm', AUTHOR => 'Steve Bertrand ') : ()), LIBS => [], DEFINE => '', INC => '', 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' => 0, 'Test::More' => 0, 'Test::SharedFork' => 0.35, }, PREREQ_PM => { 'JSON' => 0, 'Scalar::Util' => 0, 'Storable' => 0.607, 'String::CRC32' => 0, }, ); IPC-Shareable-1.13/CREDITS000644 000765 000024 00000001573 14210441431 015246 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.13/META.json000644 000765 000024 00000002722 14321403012 015640 0ustar00stevestaff000000 000000 { "abstract" : "Use shared memory backed variables across processes", "author" : [ "Steve Bertrand " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.44, 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" : "0", "Test::More" : "0", "Test::SharedFork" : "0.35" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.72" } }, "runtime" : { "requires" : { "JSON" : "0", "Scalar::Util" : "0", "Storable" : "0.607", "String::CRC32" : "0", "perl" : "5.01" } } }, "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.13", "x_serialization_backend" : "JSON::PP version 4.04" } IPC-Shareable-1.13/lib/IPC/000755 000765 000024 00000000000 14321403012 015375 5ustar00stevestaff000000 000000 IPC-Shareable-1.13/lib/IPC/Shareable.pm000644 000765 000024 00000134602 14321402704 017636 0ustar00stevestaff000000 000000 package IPC::Shareable; use warnings; use strict; require 5.00503; use Carp qw(croak confess carp); use Data::Dumper; use IPC::Semaphore; use IPC::Shareable::SharedMem; use IPC::SysV qw( IPC_PRIVATE IPC_CREAT IPC_EXCL IPC_NOWAIT SEM_UNDO ); use JSON qw(-convert_blessed_universally); use Scalar::Util; use String::CRC32; use Storable 0.6 qw(freeze thaw); our $VERSION = '1.13'; use constant { LOCK_SH => 1, LOCK_EX => 2, LOCK_NB => 4, LOCK_UN => 8, DEBUGGING => ($ENV{SHAREABLE_DEBUG} or 0), SHM_BUFSIZ => 65536, SEM_MARKER => 0, SHM_EXISTS => 1, SHMMAX_BYTES => 1073741824, # 1 GB # 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, EXCLUSIVE_CHECK_LIMIT => 10, # Number of times we'll check for existing segs }; require Exporter; our @ISA = 'Exporter'; our @EXPORT_OK = qw(LOCK_EX LOCK_SH LOCK_NB LOCK_UN); our %EXPORT_TAGS = ( all => [qw( LOCK_EX LOCK_SH LOCK_NB LOCK_UN )], lock => [qw( LOCK_EX LOCK_SH LOCK_NB LOCK_UN )], flock => [qw( LOCK_EX LOCK_SH LOCK_NB LOCK_UN )], ); Exporter::export_ok_tags('all', 'lock', 'flock'); # Locking scheme copied from IPC::ShareLite -- ltl my %semop_args = ( (LOCK_EX), [ 1, 0, 0, # wait for readers to finish 2, 0, 0, # wait for writers to finish 2, 1, SEM_UNDO, # assert write lock ], (LOCK_EX|LOCK_NB), [ 1, 0, IPC_NOWAIT, # wait for readers to finish 2, 0, IPC_NOWAIT, # wait for writers to finish 2, 1, (SEM_UNDO | IPC_NOWAIT), # assert write lock ], (LOCK_EX|LOCK_UN), [ 2, -1, (SEM_UNDO | IPC_NOWAIT), ], (LOCK_SH), [ 2, 0, 0, # wait for writers to finish 1, 1, SEM_UNDO, # assert shared read lock ], (LOCK_SH|LOCK_NB), [ 2, 0, IPC_NOWAIT, # wait for writers to finish 1, 1, (SEM_UNDO | IPC_NOWAIT), # assert shared read lock ], (LOCK_SH|LOCK_UN), [ 1, -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, limit => 1, graceful => 0, warn => 0, tidy => 0, serializer => 'storable', ); my %global_register; my %process_register; my %used_ids; sub _trace; sub _debug; # --- "Magic" methods sub TIESCALAR { return _tie('SCALAR', @_); } sub TIEARRAY { return _tie('ARRAY', @_); } sub TIEHASH { return _tie('HASH', @_); } sub STORE { my $knot = shift; if (! exists $global_register{$knot->seg->id}) { $global_register{$knot->seg->id} = $knot; } $knot->{_data} = $knot->_decode($knot->seg) unless ($knot->{_lock}); if ($knot->{_type} eq 'HASH') { my ($key, $val) = @_; _mg_tie($knot, $val, $key) if $knot->_need_tie($val, $key); $knot->{_data}{$key} = $val; } elsif ($knot->{_type} eq 'ARRAY') { my ($i, $val) = @_; _mg_tie($knot, $val, $i) if $knot->_need_tie($val, $i); $knot->{_data}[$i] = $val; } elsif ($knot->{_type} eq 'SCALAR') { my ($val) = @_; _mg_tie($knot, $val) if $knot->_need_tie($val); $knot->{_data} = \$val; } else { croak "Variables of type $knot->{_type} not supported"; } if ($knot->{_lock} & LOCK_EX) { $knot->{_was_changed} = 1; } else { if (! defined $knot->_encode($knot->seg, $knot->{_data})){ croak "Could not write to shared memory: $!\n"; } } return 1; } sub FETCH { my $knot = shift; if (! exists $global_register{$knot->seg->id}) { $global_register{$knot->seg->id} = $knot; } my $data; if ($knot->{_lock} || $knot->{_iterating}) { $knot->{_iterating} = 0; # In case we break out $data = $knot->{_data}; } else { $data = $knot->_decode($knot->seg); $knot->{_data} = $data; } my $val; if ($knot->{_type} eq 'HASH') { if (defined $data) { my $key = shift; $val = $data->{$key}; } else { return; } } elsif ($knot->{_type} eq 'ARRAY') { if (defined $data) { my $i = shift; $val = $data->[$i]; } else { return; } } elsif ($knot->{_type} eq 'SCALAR') { if (defined $data) { $val = $$data; } else { return; } } else { croak "Variables of type $knot->{_type} not supported"; } if (my $inner = _is_kid($val)) { my $s = $inner->seg; $inner->{_data} = $knot->_decode($s); } return $val; } sub CLEAR { my $knot = shift; if ($knot->{_type} eq 'HASH') { $knot->{_data} = { }; } elsif ($knot->{_type} eq 'ARRAY') { $knot->{_data} = [ ]; } else { croak "Attempt to clear non-aggegrate"; } if ($knot->{_lock} & LOCK_EX) { $knot->{_was_changed} = 1; } else { if (! defined $knot->_encode($knot->seg, $knot->{_data})){ croak "Could not write to shared memory: $!"; } } } sub DELETE { my $knot = shift; my $key = shift; $knot->{_data} = $knot->_decode($knot->seg) unless $knot->{_lock}; my $val = delete $knot->{_data}->{$key}; if ($knot->{_lock} & LOCK_EX) { $knot->{_was_changed} = 1; } else { if (! defined $knot->_encode($knot->seg, $knot->{_data})){ croak "Could not write to shared memory: $!"; } } 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->{_iterating} = 1; $knot->{_data} = $knot->_decode($knot->seg) unless $knot->{_lock}; my $reset = keys %{$knot->{_data}}; my $first = each %{$knot->{_data}}; return $first; } sub NEXTKEY { my $knot = shift; # caveat emptor if hash was changed by another process my $next = each %{$knot->{_data}}; if (not defined $next) { $knot->{_iterating} = 0; return; } else { $knot->{_iterating} = 1; return $next; } } sub EXTEND { #XXX Noop } sub PUSH { my $knot = shift; if (! exists $global_register{$knot->seg->id}) { $global_register{$knot->seg->id} = $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 { if (! defined $knot->_encode($knot->seg, $knot->{_data})){ croak "Could not write to shared memory: $!"; }; } } sub POP { my $knot = shift; $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 { if (! defined $knot->_encode($knot->seg, $knot->{_data})){ croak "Could not write to shared memory: $!"; } } return $val; } sub SHIFT { my $knot = shift; $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 { if (! defined $knot->_encode($knot->seg, $knot->{_data})){ croak "Could not write to shared memory: $!"; } } return $val; } sub UNSHIFT { my $knot = shift; $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 { if (! defined $knot->_encode($knot->seg, $knot->{_data})){ croak "Could not write to shared memory: $!"; } } return $val; } sub SPLICE { my($knot, $off, $n, @av) = @_; $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 { if (! defined $knot->_encode($knot->seg, $knot->{_data})){ croak "Could not write to shared memory: $!"; } } return @val; } sub FETCHSIZE { my $knot = shift; $knot->{_data} = $knot->_decode($knot->seg) unless $knot->{_lock}; return scalar(@{$knot->{_data}}); } sub STORESIZE { my $knot = shift; my $n = shift; $knot->{_data} = $knot->_decode($knot->seg) unless $knot->{_lock}; $#{$knot->{_data}} = $n - 1; if ($knot->{_lock} & LOCK_EX) { $knot->{_was_changed} = 1; } else { if (! defined $knot->_encode($knot->seg, $knot->{_data})){ croak "Could not write to shared memory: $!"; } } return $n; } # --- Public methods sub new { my ($class, %opts) = @_; my $type = $opts{var} || 'HASH'; if ($type eq 'HASH') { my $k = tie my %h, 'IPC::Shareable', \%opts; return \%h; } if ($type eq 'ARRAY') { my $k = tie my @a, 'IPC::Shareable', \%opts; return \@a; } if ($type eq 'SCALAR') { my $k = tie my $s, 'IPC::Shareable', \%opts; return \$s; } } sub global_register { # This is a ridiculous way to do this, but if we don't call Dumper, hashes # that are created in a separate process than the parent hash don't # show up properly in the global register. t/81 local $SIG{__WARN__} = sub { my ($warning) = @_; if ($warning !~ /hash after insertion/) { warn $warning; } }; Dumper \%global_register; return \%global_register; } sub process_register { return \%process_register; } sub attributes { my ($knot, $attr) = @_; my $attrs = $knot->{attributes}; if (defined $attr) { return $knot->{attributes}{$attr}; } else { return $knot->{attributes}; } } sub ipcs { my $count = `ipcs -m | wc -l`; chomp $count; return int($count); } sub lock { my ($knot, $flags) = @_; $flags = LOCK_EX if ! defined $flags; return $knot->unlock if ($flags & LOCK_UN); return 1 if ($knot->{_lock} & $flags); # If they have a different lock than they want, release it first $knot->unlock if ($knot->{_lock}); my $sem = $knot->sem; my $return_val = $sem->op(@{ $semop_args{$flags} }); if ($return_val) { $knot->{_lock} = $flags; $knot->{_data} = $knot->_decode($knot->seg), } return $return_val; } sub unlock { my $knot = shift; return 1 unless $knot->{_lock}; if ($knot->{_was_changed}) { if (! defined $knot->_encode($knot->seg, $knot->{_data})){ croak "Could not write to shared memory: $!\n"; } $knot->{_was_changed} = 0; } my $sem = $knot->sem; my $flags = $knot->{_lock} | LOCK_UN; $flags ^= LOCK_NB if ($flags & LOCK_NB); $sem->op(@{ $semop_args{$flags} }); $knot->{_lock} = 0; 1; } *shlock = \&lock; *shunlock = \&unlock; 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 = shift; my $s = $knot->seg; my $id = $s->id; $s->remove or warn "Couldn't remove shared memory segment $id: $!"; $s = $knot->sem; $s->remove or warn "Couldn't remove semaphore set $id: $!"; delete $process_register{$id}; delete $global_register{$id}; } sub seg { my ($knot) = @_; return $knot->{_shm} if defined $knot->{_shm}; } sub sem { my ($knot) = @_; return $knot->{_sem} if defined $knot->{_sem}; } 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 $$; } END { _end(); } # --- Private methods below sub _encode { my ($knot, $seg, $data) = @_; my $serializer = $knot->attributes('serializer'); if ($serializer eq 'storable') { return _freeze($seg, $data); } elsif ($serializer eq 'json'){ return _encode_json($seg, $data); } return undef; } sub _end { for my $s (values %process_register) { unlock($s); next if $s->attributes('protected'); next if ! $s->attributes('destroy'); next if $s->attributes('owner') != $$; remove($s); } } sub _decode { my ($knot, $seg) = @_; my $serializer = $knot->attributes('serializer'); if ($serializer eq 'storable') { return _thaw($seg); } elsif ($serializer eq 'json'){ return _decode_json($seg); } return undef; } sub _encode_json { my $seg = shift; my $data = shift; my $json = encode_json $data; if (length($json) > $seg->size) { croak "Length of shared data exceeds shared segment size"; } $seg->shmwrite($json); } sub _decode_json { my $seg = shift; my $json = $seg->shmread; return if ! $json; # Remove \x{0} after end of string (broke JSON) $json =~ s/\x00+//; # 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?)"; } return $data; # } else { # return; # } } sub _freeze { my $seg = shift; my $water = shift; my $ice = freeze $water; # Could be a large string. No need to copy it. substr more efficient 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 = shift; 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; } } sub _tie { my ($type, $class, $key_str, $opts); if (scalar @_ == 4) { ($type, $class, $key_str, $opts) = @_; $opts->{key} = $key_str; } else { ($type, $class, $opts) = @_; } $opts = _parse_args($opts); my $knot = bless { attributes => $opts }, $class; 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, $shm_size, $flags); 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, $shm_size, $flags); } if (! defined $seg) { if ($! =~ /Cannot allocate memory/) { croak "\nERROR: Could not create shared memory segment: $!\n\n" . "Are you using too large a size?"; } if ($! =~ /No space left on device/) { croak "\nERROR: Could not create shared memory segment: $!\n\n" . "Are you spawning too many segments in a loop?"; } 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$!"; } } my $sem = IPC::Semaphore->new($key, 3, $flags); if (! defined $sem){ croak "Could not create semaphore set: $!\n"; } if (! $sem->op(@{ $semop_args{(LOCK_SH)} }) ) { croak "Could not obtain semaphore set lock: $!\n"; } %$knot = ( %$knot, _iterating => 0, _key => $key, _lock => 0, _shm => $seg, _sem => $sem, _type => $type, _was_changed => 0, ); $knot->{_data} = _thaw($seg); if ($sem->getval(SEM_MARKER) != SHM_EXISTS) { if (! exists $global_register{$knot->seg->id}) { $global_register{$knot->seg->id} = $knot; } $process_register{$knot->seg->id} ||= $knot; if (! $sem->setval(SEM_MARKER, SHM_EXISTS)){ croak "Couldn't set semaphore during object creation: $!"; } } $sem->op(@{ $semop_args{(LOCK_SH|LOCK_UN)} }); return $knot; } sub _parse_args { my ($opts) = @_; $opts = defined $opts ? $opts : { %default_options }; 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; } } $opts->{owner} = ($opts->{owner} or $$); $opts->{magic} = ($opts->{magic} or 0); return $opts; } 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 =~ /^\d+$/) { $key = $key_str; } else { $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; # Unfortunatly, 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, 1, $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 { srand(); return int(rand(1_000_000)); } 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');; $flags |= ($knot->attributes('mode') or 0666); return $flags; } sub _mg_tie { my ($parent, $val, $identifier) = @_; my $key; if ($parent->{_key} == IPC_PRIVATE) { $key = IPC_PRIVATE; } else { $key = _shm_key_rand(); } 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; _reset_segment($parent, $identifier) if $opts{tidy}; %$val = %copy; } elsif ($type eq "ARRAY") { my @copy = @$val; $child = tie @$val, 'IPC::Shareable', $key, { %opts }; croak "Could not create inner tie" if ! $child; _reset_segment($parent, $identifier) if $opts{tidy}; @$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 _is_kid { 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 _need_tie { my ($knot, $val, $identifier) = @_; 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 _reset_segment { my ($parent, $id) = @_; my $parent_type = Scalar::Util::reftype($parent->{_data}) || ''; if ($parent_type eq 'HASH') { my $data = $parent->{_data}; if (exists $data->{$id} && keys %{ $data->{$id} } && tied %{ $data->{$id} }) { (tied %{ $parent->{_data}{$id} })->remove; } } elsif ($parent_type eq 'ARRAY') { my $data = $parent->{_data}; if (exists $data->[$id] && tied @{ $data->[$id] }) { (tied @{ $parent->{_data}[$id] })->remove; } } } sub _trace { require Carp; require Data::Dumper; my $caller = ' ' . (caller(1))[3] . " called with:\n"; my $i = -1; my @msg = map { ++$i; my $obj; if (ref eq 'IPC::Shareable') { ' ' . "\$_[$i] = $_: shmid: $_->{_shm}->{_id}; " . Data::Dumper->Dump([ $_->attributes ], [ 'opts' ]); } else { ' ' . Data::Dumper->Dump( [ $_ ] => [ "\_[$i]" ]); } } @_; Carp::carp "IPC::Shareable ($$) debug:\n", $caller, @msg; } sub _debug { require Carp; require Data::Dumper; local $Data::Dumper::Terse = 1; my $caller = ' ' . (caller(1))[3] . " tells us that:\n"; my @msg = map { my $obj; if (ref eq 'IPC::Shareable') { ' ' . "$_: shmid: $_->{_shm}->{_id}; " . Data::Dumper->Dump([ $_->attributes ], [ 'opts' ]); } else { ' ' . Data::Dumper::Dumper($_); } } @_; Carp::carp "IPC::Shareable ($$) debug:\n", $caller, @msg; } 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); my $href = IPC::Shareable->new(%options); # ...or tie SCALAR, 'IPC::Shareable', OPTIONS; tie ARRAY, 'IPC::Shareable', OPTIONS; tie HASH, 'IPC::Shareable', OPTIONS; tied(VARIABLE)->lock; tied(VARIABLE)->unlock; tied(VARIABLE)->lock(LOCK_SH|LOCK_NB) or print "Resource unavailable\n"; my $segment = tied(VARIABLE)->seg; my $semaphore = tied(VARIABLE)->sem; tied(VARIABLE)->remove; IPC::Shareable::clean_up; IPC::Shareable::clean_up_all; IPC::Shareable::clean_up_protected; # Ensure only one instance of a script can be run at any time IPC::Shareable->singleton('UNIQUE SCRIPT LOCK STRING'); # Get the actual IPC::Shareable tied object my $knot = tied(VARIABLE); # Dereference first if using a tied reference =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. The association between variables in distinct processes is provided by GLUE (aka "key"). This is any arbitrary string or integer that serves as a common identifier for data across process space. Hence the statement: tie my $scalar, 'IPC::Shareable', { key => 'GLUE STRING', create => 1 }; ...in program one and the statement tie my $variable, 'IPC::Shareable', { key => 'GLUE STRING' }; ...in program two will create and bind C<$scalar> the shared memory in program one and bind it to C<$variable> 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 (the exact value is system-dependent). The bound data structures are all linearized (using Raphael Manfredi's L module 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. =head1 OPTIONS Options are specified by passing a reference to a hash as the third argument to the C function that enchants a variable. 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. This default key will not allow sharing of the variable between processes. 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. Defult: 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. Useful for ensuring only a single process is running at a time. 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, C<0600> is readable only by the effective UID of the process creating the shared variable, etc. Default: B<0666> (world read and writeable) =head2 size This field may be used to specify the size of the shared memory segment allocated. The maximum size we allow by default is ~1GB. See the L option to override this default. Default: C (ie. B<65536>) =head2 protected If set, the C and C routines will not remove the segments or semaphores related to the tied object. Set this to a specific integer so we can pass the value to any child objects created under the main one. 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. Default: B<0> =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 (gracefully)[1]. 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 tidy For long running processes, set this to a true value to clean up unneeded segments from nested data structures. Comes with a slight performance hit. 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 purposes, you can optionally use L for this task. Send in either C or C as the value to use the respective serializer. 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, limit => 1, destroy => 0, graceful => 0, warn => 0, tidy => 0, serializer => 'storable', =head1 METHODS =head2 new 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)->ipcs; Parameters: Hash, Optional: See the L section for a list of all available options. Most often, you'll want to 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 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 =head2 ipcs Returns the number of instantiated shared memory segments that currently exist on the system. This isn't precise; it simply does a C line count on your system's C call. It is guaranteed though to produce reliable results. Return: Integer =head2 lock($flags) 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 values for C<$flags> are the same as for the C system call. Returns C on success, and C on error. For non-blocking calls (see below), 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> if it would have had to wait to obtain the lock. Note that 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. Locks are inherited through forks, which means that two processes actually can possess an exclusive lock at the same time. Don't do that. 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 flock constants available in the Fcntl module. See L for further details. =head2 unlock Removes a lock. Takes no parameters, returns C on success. This is equivalent of calling C. See L for further details. =head2 seg Called on either the tied variable or the tie object, returns the shared memory segment object currently in use. =head2 sem Called on either the tied variable or the tie object, returns the semaphore object related to the memory segment currently in use. =head2 attributes Retrieves the list of attributes that drive the L 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. Attributes are the C that were used to create the object. 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. 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. The key is the memory segment ID, and the value is the segment and semaphore objects. =head1 LOCKING IPC::Shareable provides methods to implement application-level advisory locking of the shared data structures. These methods are called 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. To lock and subsequently unlock a variable, do this: my $knot = tie my %hash, 'IPC::Shareable', { %options }; $knot->lock; $hash{a} = 'foo'; $knot->unlock; or equivalently, if you've decided to throw away the return of C: tie my %hash, 'IPC::Shareable', { %options }; tied(%hash)->lock; $hash{a} = 'foo'; tied(%hash)->unlock; This will place an exclusive lock on the data of C<$scalar>. 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. 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. There are some pitfalls regarding locking and signals about which you should make yourself aware; these are discussed in L. 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. =head1 DESTRUCTION perl(1) will destroy the object underlying a tied variable when then 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. =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. B: The destruction is handled in an C block. Only those memory segments that are tied to the current process will be removed. 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. =head2 remove tied($var)->remove; # or $knot->remove; Calling C on the object underlying a Cd variable removes the associated shared memory segments. 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. =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. 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 wit the C option =head1 RETURN VALUES Calls to C that try to implement L will return an instance of C on success, and C otherwise. =head1 AUTHOR Benjamin Sugars =head1 MAINTAINED BY Steve Bertrand =head1 NOTES =head2 Footnotes from the above sections =over 4 =item 1 If the process has been smoked by an untrapped signal, the binding will remain in shared memory. If you're cautious, you might try: $SIG{INT} = \&catch_int; sub catch_int { die; } ... tie $variable, IPC::Shareable, { key => 'GLUE', create => 1, 'destroy' => 1 }; which will at least clean up after your user hits CTRL-C because IPC::Shareable's END method will be called. Or, maybe you'd like to leave the binding in shared memory, so subsequent process can recover the data... =back =head2 General Notes =over 4 =item o 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 an exclusive lock, C will not be called and the lock may be maintained even though the process has exited. If this scares you, you might be better off implementing your own locking methods. One advantage of using C on some known file instead of the locking implemented with semaphores in C is that when a process dies, it automatically releases any locks. This only happens with C if the process dies gracefully. The alternative is to attempt to account for every possible calamitous ending for your process (robust signal handling in Perl is a source of much debate, though it usually works just fine) or to become familiar with your system's tools for removing shared memory and semaphores. This concern should be balanced against the significant performance improvements you can gain for larger data structures by using the locking mechanism implemented in IPC::Shareable. =item o There is a program called C(1/8) (and C(1/8)) that is available on at least Solaris and Linux that might be useful for cleaning moribund shared memory segments or semaphore sets produced by bugs in either L or applications using it. Examples: # List all semaphores and memory segments in use on the system ipcs -a # List all memory segments and semaphores along with each one's associated process ID ipcs -ap # List just the shared memory segments ipcs -m # List the details of an individual memory segment ipcs -i 12345678 # Remove *all* semaphores and memory segments ipcrm -a =item o This version of L does not understand the format of shared memory segments created by versions prior to C<0.60>. If you try to tie to such segments, you will get an error. The only work around is to clear the shared memory segments and start with a fresh set. =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). For tied hashes, the C/C operation is performed when the first key is accessed. Subsequent key and 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. IPC-Shareable-1.13/lib/IPC/Shareable/000755 000765 000024 00000000000 14321403012 017263 5ustar00stevestaff000000 000000 IPC-Shareable-1.13/lib/IPC/Shareable/SharedMem.pm000644 000765 000024 00000005552 14213443206 021506 0ustar00stevestaff000000 000000 package IPC::Shareable::SharedMem; use warnings; use strict; use Carp qw(carp croak confess); use IPC::SysV qw(IPC_RMID); our $VERSION = '1.13'; use constant DEBUGGING => ($ENV{SHM_DEBUG} or 0); my $default_size = 1024; sub default_size { my $class = shift; $default_size = shift if @_; return $default_size; } sub new { my($class, $key, $size, $flags, $type) = @_; defined $key or do { confess "usage: IPC::SharedMem->new(KEY, [ SIZE, [ FLAGS ] ])"; }; $size ||= $default_size; $flags ||= 0; my $id = shmget($key, $size, $flags); defined $id or do { if ($! =~ /File exists/){ croak "\nERROR: IPC::Shareable::SharedMem: shmget $key: $!\n\n" . "Are you using exclusive, but trying to create multiple " . "instances?\n\n"; } return undef; }; my $sh = { _id => $id, _key => $key, _size => $size, _flags => $flags, _type => $type, }; return bless $sh => $class; } sub id { my $self = shift; $self->{_id} = shift if @_; return $self->{_id}; } sub key { my $self = shift; $self->{_key} = shift if @_; return $self->{_key}; } sub flags { my $self = shift; $self->{_flags} = shift if @_; return $self->{_flags}; } sub size { my $self = shift; $self->{_size} = shift if @_; return $self->{_size}; } sub type { my $self = shift; $self->{_type} = shift if @_; return $self->{_type}; } sub shmwrite { my($self, $data) = @_; return shmwrite($self->{_id}, $data, 0, $self->{_size}); } sub shmread { my $self = shift; my $data = ''; shmread($self->{_id}, $data, 0, $self->{_size}) or return; return $data; } sub remove { my $to_remove = shift; my $id; if (ref $to_remove eq __PACKAGE__){ $id = $to_remove->{_id}; } my $arg = 0; my $ret = shmctl($id, IPC_RMID, $arg); return $ret; } 1; =head1 NAME IPC::Shareable::SharedMem - Object oriented interface to shared memory =for html Coverage Status =head1 SYNOPSIS *** No public interface *** =head1 WARNING This module is not intended for public consumption. It is used internally by IPC::Shareable to access shared memory. =head1 DESCRIPTION This module provides and object-oriented framework to access shared memory. Its use is intended to be limited to IPC::Shareable. Therefore I have not documented an interface. =head1 AUTHOR Ben Sugars (bsugars@canoe.ca) =head1 SEE ALSO L, L IPC-Shareable-1.13/benchmarks/storable_vs_json.pl000755 000765 000024 00000003050 14210441431 022247 0ustar00stevestaff000000 000000 #!/usr/bin/env perl use warnings; use strict; use Benchmark qw(:all) ; use Data::Dumper; use IPC::Shareable; use JSON qw(-convert_blessed_universally); use Storable qw(freeze thaw); if (@ARGV < 1){ print "\n Need test count argument...\n\n"; exit; } my %j_hash; my %s_hash; #timethese($ARGV[0], # { # json => \&json, # store => \&storable, # }, #); cmpthese($ARGV[0], { json => \&json, store => \&storable, }, ); sub default { return { a => 1, b => 2, c => [qw(1 2 3)], d => {z => 26, y => 25}, }; } sub json { my $base_data = default(); if (! %j_hash) { tie %j_hash, 'IPC::Shareable', { create => 1, destroy => 1, serializer => 'json' }; } %j_hash = %$base_data; $j_hash{struct1} = {a => [qw(b c d)]}; tied(%j_hash)->clean_up_all; } sub storable { my $base_data = default(); if (! %s_hash) { tie %s_hash, 'IPC::Shareable', { create => 1, destroy => 1, serializer => 'storable' }; } %s_hash = %$base_data; $s_hash{struct1} = {a => [qw(b c d)]}; # $s_hash{struct2} = {a => [qw(b c d)]}; # $s_hash{struct3} = {a => [qw(b c d)]}; # $s_hash{struct4} = {a => [qw(b c d)]}; # $s_hash{struct5} = {a => [qw(b c d)]}; # $s_hash{struct6} = {a => [qw(b c d)]}; # $s_hash{struct7} = {a => [qw(b c d)]}; # $s_hash{struct8} = {a => [qw(b c d)]}; tied(%s_hash)->clean_up_all; } __END__ IPC-Shareable-1.13/benchmarks/bench_changes.pl000755 000765 000024 00000002615 14210441431 021450 0ustar00stevestaff000000 000000 #!/usr/bin/env perl use warnings; use strict; use Benchmark qw(:all); use Data::Dumper; use IPC::Shareable; if (@ARGV < 1){ print "\n Need test count argument...\n\n"; exit; } my $timethis = 1; my $timethese = 0; my $cmpthese = 0; if ($timethis) { timethis($ARGV[0], \&shareable); #timethis($ARGV[0], \&sharedhash); } if ($timethese) { timethese($ARGV[0], { 'shareable' => \&shareable, # 'shared_hash' => \&sharedhash, }, ); } if ($cmpthese) { cmpthese($ARGV[0], { 'shareable' => \&shareable, # 'sharedhash ' => \&sharedhash, }, ); } sub default { return { a => 1, b => 2, c => [qw(1 2 3)], d => {z => 26, y => 25}, }; } sub shareable { work('IPC::Shareable'); } sub sharedhash { # work('IPC::SharedHash'); } sub work { my ($pkg) = @_; my $base_data = default(); tie my %hash, $pkg, { key => 'hash', create => 1, destroy => 1, }; %hash = %$base_data; for (1..100) { $hash{struct} = { a => [ qw(b c d) ] }; $hash{array} = [ qw(1 2 3) ]; $hash{b} = 3; delete $hash{b}; $hash{b} = 4; } tied(%hash)->clean_up_all; } __END__ Rate shareable sharedhash shareable 223/s -- -95% sharedhash 4808/s 2058% -- IPC-Shareable-1.13/benchmarks/bench_results.txt000644 000765 000024 00000001041 14210441431 021732 0ustar00stevestaff000000 000000 # 651d14bd steve@dev-vps:~/repos/ipc-shareable$ perl benchmarks/bench_changes.pl 30000 timethis 30000: 115 wallclock secs (65.40 usr + 48.62 sys = 114.02 CPU) @ 263.11/s (n=30000) steve@dev-vps:~/repos/ipc-shareable$ perl benchmarks/bench_changes.pl 30000 timethis 30000: 117 wallclock secs (70.56 usr + 45.25 sys = 115.81 CPU) @ 259.04/s (n=30000) # after adding for loop steve@dev-vps:~/repos/ipc-shareable$ perl benchmarks/bench_changes.pl 1000 timethis 1000: 250 wallclock secs (161.97 usr + 86.54 sys = 248.51 CPU) @ 4.02/s (n=1000) IPC-Shareable-1.13/benchmarks/shared.pl000644 000765 000024 00000002216 14210473457 020156 0ustar00stevestaff000000 000000 use warnings; use strict; use Async::Event::Interval; use IPC::Shareable; tie my %shared_data, 'IPC::Shareable', { key => '123456789', create => 1, destroy => 1 }; $shared_data{called_count}{$$}++; my $event_one = Async::Event::Interval->new(0.2, \&update); my $event_two = Async::Event::Interval->new(1, \&update); $event_one->start; $event_two->start; sleep 5; $event_one->stop; $event_two->stop; for my $pid (keys %{ $shared_data{called_count} }) { printf( "Process ID %d executed %d times\n", $pid, $shared_data{called_count}->{$pid} ); } for my $event ($event_one, $event_two) { printf( "Event ID %d with PID %d ran %d times, with %d errors and an interval" . " of %.2f seconds\n", $event->id, $event->pid, $event->runs, $event->errors, $event->interval ); } sub update { # Because each event runs in its own process, $$ will be set to the # process ID of the calling event, even though they both call this # same function $shared_data{called_count}->{$$}++; } END { (tied %shared_data)->clean_up_all; }IPC-Shareable-1.13/benchmarks/sereal_vs_storable_vs_json_without_ipc.pl000755 000765 000024 00000002715 14210441431 026737 0ustar00stevestaff000000 000000 #!/usr/bin/env perl use warnings; use strict; use Benchmark qw(:all) ; use JSON qw(-convert_blessed_universally); use Sereal qw(encode_sereal decode_sereal looks_like_sereal); use Storable qw(freeze thaw); if (@ARGV < 1){ print "\n Need test count argument...\n\n"; exit; } timethese($ARGV[0], { sereal => \&serial, store => \&storable, json => \&json, }, ); cmpthese($ARGV[0], { sereal => \&serial, store => \&storable, json => \&json, }, ); sub _data { my %h = ( a => 1, b => 2, c => [qw(1 2 3)], d => {z => 26, y => 25}, ); return \%h; } sub json { my $data = _data(); my $json = encode_json $data; my $perl = decode_json $json; } sub serial { my $data = _data(); my $enc = encode_sereal($data); my $dec = decode_sereal($enc); } sub storable { my $data = _data(); my $ice = freeze($data); my $water = thaw($ice); } __END__ Benchmark: timing 5000000 iterations of json, sereal, store... json: 17 wallclock secs (17.53 usr + 0.00 sys = 17.53 CPU) @ 285225.33/s (n=5000000) sereal: 22 wallclock secs (21.78 usr + 0.00 sys = 21.78 CPU) @ 229568.41/s (n=5000000) store: 49 wallclock secs (49.55 usr + 0.01 sys = 49.56 CPU) @ 100887.81/s (n=5000000) Rate store sereal json store 102312/s -- -56% -64% sereal 233863/s 129% -- -18% json 286862/s 180% 23% -- IPC-Shareable-1.13/examples/new.pl000644 000765 000024 00000000540 14213441420 017164 0ustar00stevestaff000000 000000 use warnings; use strict; use feature 'say'; use Data::Dumper; use IPC::Shareable; say "Before: " . IPC::Shareable::ipcs; my $h = IPC::Shareable->new( key => 'blah', create => 1, destroy => 1 ); $h->{one}{two} = 'hello, world!'; $h->{one}{three}{four} = 1; print Dumper $h; IPC::Shareable::_end; say "After: " . IPC::Shareable::ipcs; IPC-Shareable-1.13/testing/sharelite_with_sereal.pl000644 000765 000024 00000000776 14210441431 022612 0ustar00stevestaff000000 000000 use warnings; use strict; use feature 'say'; use Data::Dumper; use Sereal qw(encode_sereal decode_sereal); use IPC::ShareLite; my %shm_opts = ( -key => 'test', -create => 1, -destroy => 1, -exclusive => 0, -mode => 0666, # -flags => $flags, -size => 999 ); my $s = IPC::ShareLite->new(%shm_opts); my %hash = (a => 1, b => 2); $s->store(encode_sereal(\%hash)); my $d = decode_sereal($s->fetch); print Dumper $d; print Dumper $s; say $s->shmid; IPC-Shareable-1.13/testing/new_two.pl000644 000765 000024 00000000271 14210441431 017714 0ustar00stevestaff000000 000000 use warnings; use strict; use Data::Dumper; use IPC::Shareable; my $h = IPC::Shareable->new({key => 123456, create => 1, destroy => 1}); $h->{2} = 2; print "Two:\n"; print Dumper $h;IPC-Shareable-1.13/testing/new_one.pl000644 000765 000024 00000000304 14210441431 017661 0ustar00stevestaff000000 000000 use warnings; use strict; use Data::Dumper; use IPC::Shareable; my $h = IPC::Shareable->new({key => 123456, create => 1, destroy => 1}); $h->{1} = 1; sleep 5; print "One:\n"; print Dumper $h;IPC-Shareable-1.13/testing/one_deep_hash.pl000644 000765 000024 00000000431 14210441431 021011 0ustar00stevestaff000000 000000 use warnings; use strict; use Data::Dumper; use IPC::Shareable; tie my %h, 'IPC::Shareable', {key => 'hash', create => 1, destroy => 1}; $h{a} = {z => 26, y => {1 => 2}}; $h{b} = 12; $h{c} = {m => {3 => 3}}; $h{c}->{n} = 3; <>; print Dumper \%h; IPC::Shareable->clean_up_all; IPC-Shareable-1.13/testing/two_deep_hash.pl000644 000765 000024 00000000261 14210441431 021042 0ustar00stevestaff000000 000000 use warnings; use strict; use Data::Dumper; use IPC::Shareable; tie my %h, 'IPC::Shareable', {key => 'hash'}; print Dumper \%h; $h{adsf} = {a => [0, 1]}; print Dumper \%h; IPC-Shareable-1.13/t/25-ipc.t000644 000765 000024 00000001776 14211240047 015663 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use IPC::Shareable; use Test::More; use Test::SharedFork; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; my $awake = 0; local $SIG{ALRM} = sub { $awake = 1 }; my $pid = fork; defined $pid or die "Cannot fork: $!"; if ($pid == 0) { # child sleep unless $awake; tie my %h, 'IPC::Shareable', { key => 'testing25', destroy => 0 }; $h{a} = 'foo'; exit; } else { # parent tie my %h, 'IPC::Shareable', { key => 'testing25', create => 1, destroy => 1, }; $h{a} = 'bar'; is $h{a}, 'bar', "in parent: parent set HV to 'bar' ok"; kill ALRM => $pid; waitpid($pid, 0); is $h{a}, 'foo', "in parent: child set HV to 'foo' ok"; IPC::Shareable->clean_up_all; } IPC::Shareable::_end; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/07-new.t000644 000765 000024 00000004052 14212266611 015675 0ustar00stevestaff000000 000000 use warnings; use strict; use Data::Dumper; use IPC::Shareable; use Test::More; use Test::SharedFork; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; my $mod = 'IPC::Shareable'; 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; my $ch = $mod->new(key => 'hash2'); $ch->{child} = 'child'; my $ca = $mod->new(key => 'array2', var => 'ARRAY'); $ca->[1] = 'child'; my $cs = $mod->new(key => 'scalar2', var => 'SCALAR'); $$cs = 'child'; } else { # parent my $ph = $mod->new(key => 'hash2', create => 1, destroy => 1); like tied(%$ph), qr/IPC::Shareable/, "new() tied hash is proper object ok"; like tied(%$ph)->can('ipcs'), qr/CODE/, "...and it can call its methods ok"; my $pa = $mod->new(key => 'array2', create => 1, destroy => 1, var => 'ARRAY'); like tied(@$pa), qr/IPC::Shareable/, "new() tied array is proper object ok"; like tied(@$pa)->can('ipcs'), qr/CODE/, "...and it can call its methods ok"; my $ps = $mod->new(key => 'scalar2', create => 1, destroy => 1, var => 'SCALAR'); like tied($$ps), qr/IPC::Shareable/, "new() tied scalar is proper object ok"; like tied($$ps)->can('ipcs'), qr/CODE/, "...and it can call its methods ok"; kill ALRM => $pid; 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; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); } IPC-Shareable-1.13/t/55-lsync.t000644 000765 000024 00000004140 14211255573 016241 0ustar00stevestaff000000 000000 # Test of asynchronous hash access courtesy of Tim Fries use warnings; use strict; use Carp; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; my $t = 1; my $ok = 1; my $awake = 0; local $SIG{ALRM} = sub { $awake = 1 }; my $ppid = $$; my $pid = fork; defined $pid or die "Cannot fork : $!"; if ($pid == 0) { # child sleep unless $awake; $awake = 0; tie my %thash, 'IPC::Shareable', 'hobj', { destroy => 0 }; $thash{'foo'} = "marlinspike"; $thash{'bar'} = "ballyhoo"; $thash{'quux'} = "calvinball"; kill ALRM => $ppid; sleep unless $awake; # is defined $thash{'foo'}, 1, "child: thash foo defined"; # is $thash{'foo'}, 'marlinspike', "child: thash foo val is good"; # # is defined $thash{'bar'}, 1, "child: thash bar defined"; # is $thash{'bar'}, 'ballyhoo', "child: thash bar val is good"; # # is defined $thash{'quux'}, 1, "child: thash quux defined"; # is $thash{'quux'}, 'calvinball', "child: thash quux val is good"; exit; } else { # parent my $awake = 0; local $SIG{ALRM} = sub { $awake = 1 }; tie my %thash, 'IPC::Shareable', 'hobj', { create => 'yes' }; kill ALRM => $pid; sleep unless $awake; $thash{'intel'} = "expensive"; $thash{'amd'} = "volthungry"; $thash{'cyrix'} = "mia"; kill ALRM => $pid; 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; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/64-nested_segs_untidy.t000644 000765 000024 00000005615 14211255706 021016 0ustar00stevestaff000000 000000 use warnings; use strict; use feature 'say'; use Data::Dumper; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; # array { my @test_data = ( [ 1, 2, 3, [ 26, [ 30, 31, ], ], ], ); tie my @a, 'IPC::Shareable', {create => 1, destroy => 1}; my $initial_seg_count = seg_count(); is seg_count(), $initial_seg_count, "Initial array seg count ok"; $a[0] = [3]; is seg_count(), $initial_seg_count + 1, "After initial aref add, seg count ok"; $a[0] = [1, 2]; is seg_count(), $initial_seg_count + 2, "Adding a new aref to an existing element doesn't create a new seg ok"; $a[0] = [1, 2, 3]; is seg_count(), $initial_seg_count + 3, "Same with repurposing the aref again"; $a[0] = [1, 2, 3, [26, [30, 31]]]; is seg_count(), $initial_seg_count + 6, "Same with repurposing the aref again with nested"; is_deeply \@a, \@test_data, "Nested arrays compare ok"; IPC::Shareable->clean_up_all; } # hash { my %test_data = ( a => { a => 1, b => 2, c => 3, d => { z => 26, y => { yy => 25, }, }, } ); tie my %h, 'IPC::Shareable', {create => 1, destroy => 1}; my $initial_seg_count = seg_count(); is seg_count(), $initial_seg_count, "Initial href seg count ok"; $h{a} = {a => 1}; is seg_count(), $initial_seg_count + 1, "After initial href add, seg count ok"; $h{a} = {a => 1, b => 2}; is seg_count(), $initial_seg_count + 2, "Adding a new href to an existing key doesn't create a new seg ok"; $h{a} = {a => 1, b => 2, c => 3}; is seg_count(), $initial_seg_count + 3, "Same with repurposing the href again"; $h{a} = {a => 1, b => 2, c => 3, d => {z => 26}}; is seg_count(), $initial_seg_count + 5, "Adding a new hash inside of existing does bump seg count"; $h{a} = {a => 1, b => 2, c => 3, d => {z => 26, y => {yy => 25}}}; is seg_count(), $initial_seg_count + 8, "Adding a new hash inside of two level existing does bump seg count"; $h{a} = {a => 1, b => 2, c => 3, d => {z => 26, y => {yy => 25}}}; is seg_count(), $initial_seg_count + 11, "Adding a new hash inside of two level existing twice does bump seg count"; is_deeply \%h, \%test_data, "Shared memory hash matches test data ok"; IPC::Shareable->clean_up_all; } IPC::Shareable::_end; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing; sub seg_count { my $count = `ipcs -m | wc -l`; chomp $count; $count =~ s/\s+//g; return $count; } IPC-Shareable-1.13/t/10-av.t000644 000765 000024 00000002716 14211237701 015506 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; tie my @av, 'IPC::Shareable', { destroy => 1 }; my @words = qw(tic tac toe); @av = qw(tic tac toe); for (0 .. 2) { is $av[$_], $words[$_], "shared array has been populated ok: $_"; } $#av = 5; is scalar(@av), 6, "array count ok"; for (3 .. 5) { is defined $av[$_], '', "array elem $_ is present but undefined"; } is $#av, 5, "array len ok"; @av = (); is scalar(@av), 0, "shared array cleared ok"; @av = qw(fee fie foe fum); my $fum = pop @av; is $fum, 'fum', "a pop on the array is ok"; is $#av, 2, "after pop, proper amount of elements remain ok"; push @av => $fum; is $av[3], $fum, "pushing to array ok"; is $#av, 3, "a push adds a new element ok"; # shift my $fee = shift @av; is $fee, 'fee', "shifting the array ok"; is $#av, 2, "after shift, proper number of elements ok"; # unshift unshift @av => $fee; is $fee, 'fee', "unshifting the array ok"; is $#av, 3, "after unshift, proper number of elements ok"; # splice my(@gone) = splice @av, 1, 2, qw(i spliced); is $av[1], 'i', "splice 1 ok"; is $av[2], 'spliced', "splice 2 ok"; is $gone[0], 'fie', "splice 3 ok"; is $gone[1], 'foe', "splice 4 ok"; IPC::Shareable::_end; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/15-hv.t000644 000765 000024 00000003254 14211237710 015520 0ustar00stevestaff000000 000000 use strict; use warnings; use Data::Dumper; use Test::More; use IPC::Shareable; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; my $mod = 'IPC::Shareable'; my $knot = tie my %hv, $mod, { create => 1, key => 1234, destroy => 1, # 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"; # --- CLEAR %hv = (); is keys(%hv), 0, "clearing a hash works ok"; #is exists($hv{__ipc}), 1, "__ipc__ key still exists"; IPC::Shareable->clean_up_all; is %hv, '', "hash deleted after clean_up()"; IPC::Shareable::_end; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/02-create.t000644 000765 000024 00000001115 14211237405 016335 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; my $ok = eval { tie my $sv, 'IPC::Shareable', {key => 'test02', destroy => 1}; 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; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing; IPC-Shareable-1.13/t/00-base.t000644 000765 000024 00000001731 14213441121 016000 0ustar00stevestaff000000 000000 use warnings; use strict; use Data::Dumper; use Test::More; BEGIN { if (!$ENV{CI_TESTING}) { plan skip_all => "Not on a valid CI platform..."; } use_ok('IPC::Shareable'); }; warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; my $segs = IPC::Shareable::ipcs(); print "Starting with $segs segments\n"; is $segs, $segs, "Initial test ok"; { my $a = tie my $x, 'IPC::Shareable'; my $b = tie my $y, 'IPC::Shareable', { create => 1, destroy => 1 }; 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; # Store existing segments in a shared hash to test against # at conclusion of test suite run tie my %store, 'IPC::Shareable', { key => 'async_tests', create => 1 }; $store{segs} = $segs; } IPC::Shareable::_end; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing();IPC-Shareable-1.13/t/60-tied.t000644 000765 000024 00000001047 14211255614 016031 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; tie my %hv, 'IPC::Shareable', {destroy => 1}; $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; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/81-fork_dup_rand_keys.t000644 000765 000024 00000002642 14211463374 020765 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; use Test::More; my $segs_before; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } if (! $ENV{RELEASE_TESTING}) { plan skip_all => "Developer only test..."; } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; $segs_before = IPC::Shareable::ipcs(); } use Async::Event::Interval; { tie my %shared_data, 'IPC::Shareable', { key => 'fork rand dup keys', create => 1, destroy => 1 }; my $event_one = Async::Event::Interval->new(0, sub {$shared_data{$$}{called}++}); my $event_two = Async::Event::Interval->new(0, sub {$shared_data{$$}{called}++}); $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; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; my $segs_after = IPC::Shareable::ipcs(); is $segs_after, $segs_before, "All segs, even those created in separate procs, cleaned up ok"; done_testing(); IPC-Shareable-1.13/t/66-size_exceeded.t000644 000765 000024 00000001247 14211255743 017717 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; my $k = tie my $sv, 'IPC::Shareable', { create => 1, destroy => 1, size => 1, }; 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; IPC::Shareable::_end; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/77-singleton_warn.t000644 000765 000024 00000001646 14211256137 020153 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; # 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; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing; }; IPC-Shareable-1.13/t/50-ipcobj.t000644 000765 000024 00000003760 14211255532 016354 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; 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}; } } my $awake = 0; local $SIG{ALRM} = sub { $awake = 1 }; my $pid = fork; defined $pid or die "Cannot fork : $!"; if ($pid == 0) { # child sleep unless $awake; tie my $d, 'IPC::Shareable', 'obj', { destroy => 0 }; # 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', 'obj', { create => 1, destroy => 1 }; # my $id = $s->{_shm}->{_id}; $d = { }; $d->{_first} = 'foobar'; $d->{_second} = 'barfoo'; $d = Dummy->new; $d->first('foobar'); $d->second('barfoo'); kill ALRM => $pid; 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; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/08-new_tied_obj.t000644 000765 000024 00000001213 14211237641 017531 0ustar00stevestaff000000 000000 use warnings; use strict; use Data::Dumper; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; my $mod = 'IPC::Shareable'; my $ph = $mod->new( key => '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; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/36-ipcav.t000644 000765 000024 00000003050 14211255411 016200 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; my $t = 1; my $ok = 1; my $awake = 0; local $SIG{ALRM} = sub { $awake = 1 }; my $pid = fork; defined $pid or die "Cannot fork: $!"; if ($pid == 0) { sleep unless $awake; $awake = 0; my @av; my $ipch = tie @av, 'IPC::Shareable', "foco", { create => 1, exclusive => 0, mode => 0666, size => 1024*512, destroy => 0, }; @av = (); for (my $i = 1; $i <= 10; $i++) { $ipch->shlock; push(@av, $i); $ipch->shunlock; } sleep unless $awake; @av and undef $ok; exit; } else { my @av; my $ipch = tie @av, 'IPC::Shareable', "foco", { create => 1, exclusive => 0, mode => 0666, size => 1024*512, destroy => 'yes', }; @av = (); kill ALRM => $pid; my %seen; sleep 1 until @av; while (@av) { $ipch->shlock; my $line = shift @av; ++$seen{$line}; $ipch->shunlock; } kill ALRM => $pid; 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; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/75-graceful.t000644 000765 000024 00000002614 14211256065 016704 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; # non-graceful { tie my $sv, 'IPC::Shareable', { key => 'lock', create => 1, exclusive => 1, destroy => 1 }; my $catch = eval { tie my $sv2, 'IPC::Shareable', { key => 'lock', create => 1, exclusive => 1, destroy => 1 }; 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 => 'DONE', create => 1, exclusive => 1, graceful => 1, destroy => 1 }; tie my $sv2, 'IPC::Shareable', { key => 'DONE', create => 1, exclusive => 1, graceful => 1, destroy => 1 }; } END { is $@, '', "with 'graceful', we silently exit if two attempts made on same exclusive seg"; IPC::Shareable::_end; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing; }; IPC-Shareable-1.13/t/90-pod_coverage.t000644 000765 000024 00000001231 14210441431 017530 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/^_/], ); is $pc->coverage, 1, "pod coverage ok"; if ($pc->uncovered){ warn "Uncovered:\n\t", join( ", ", $pc->uncovered ), "\n"; } done_testing; IPC-Shareable-1.13/t/99-end.t000644 000765 000024 00000001000 14211510036 015643 0ustar00stevestaff000000 000000 use 5.006; use strict; use warnings; use IPC::Shareable; use Test::More; BEGIN { use_ok( 'IPC::Shareable' ) || print "Bail out!\n"; } if (! $ENV{CI_TESTING}) { done_testing(); exit; } tie my %store, 'IPC::Shareable', {key => 'async_tests', destroy => 1}; my $start_segs = $store{segs}; IPC::Shareable::clean_up_all; my $segs = IPC::Shareable::ipcs(); is $segs, $start_segs, "All test segments cleaned up after test run"; print "Started with $start_segs, ending with $segs\n"; done_testing();IPC-Shareable-1.13/t/76-singleton.t000644 000765 000024 00000002020 14211256120 017076 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; # 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; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing; }; IPC-Shareable-1.13/t/04-key.t000644 000765 000024 00000011415 14211237434 015672 0ustar00stevestaff000000 000000 use warnings; use strict; use Data::Dumper; use IPC::Shareable; use Mock::Sub; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; # deprecated string key param { my $k; my $ok = eval { $k = tie my $sv, 'IPC::Shareable', 'TEST', {create => 1, destroy => 1}; 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}; 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}; 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}; 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}; 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}; 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}; 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}; 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}; 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; } } # _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 }; $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; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/38-ipchv.t000644 000765 000024 00000003763 14211255440 016226 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; plan tests => 8; my %shareOpts = ( create => 'yes', exclusive => 0, mode => 0644, destroy => 'yes', ); my $awake = 0; local $SIG{ALRM} = sub { $awake = 1 }; my $pid = fork; defined $pid or die "Cannot fork: $!"; if ($pid == 0) { # child sleep unless $awake; $awake = 0; my $ipch = tie my %hv, 'IPC::Shareable', "test", { create => 'yes', exclusive => 0, mode => 0644, destroy => 0, }; for (qw(fee fie foe fum)) { $ipch->shlock(); $hv{$_} = $$; $ipch->shunlock(); } sleep unless $awake; # for (qw(fee fie foe fum)) { # is $hv{$_}, $$, "child: HV key $_ has val $$"; # } my $parent = getppid; $parent == 1 and die "Parent process has unexpectedly gone away"; # for (qw(eenie meenie minie moe)) { # is $hv{$_}, $parent, "child: HV key $_ has val $parent (parent PID)"; # } } else { # parent my $ipch = tie my %hv, 'IPC::Shareable', "test", { create => 1, exclusive => 0, mode => 0666, size => 1024*512, destroy => 'yes', }; %hv = (); kill ALRM => $pid; sleep 1; # Allow time for child to process the signal before next ALRM comes in for (qw(eenie meenie minie moe)) { $ipch->shlock(); $hv{$_} = $$; $ipch->shunlock(); } kill ALRM => $pid; waitpid($pid, 0); for (qw(fee fie foe fum)) { is $hv{$_}, $pid, "parent: HV $_ has val $pid"; } for (qw(eenie meenie minie moe)) { is $hv{$_}, $$, "parent: HV $_ has val $$"; } } IPC::Shareable::_end; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; #done_testing(); IPC-Shareable-1.13/t/78-singleton_class.t000644 000765 000024 00000002034 14307670061 020304 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; # 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; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing; }; IPC-Shareable-1.13/t/82-sig_child_ignore.t000644 000765 000024 00000000737 14211256224 020403 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; my @command = ('date'); my $rc = system( @command ); is $rc, 0, "system() returns success ok after moving CHLD handler"; IPC::Shareable::_end; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/45-obj.t000644 000765 000024 00000002304 14211255515 015656 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; 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', { destroy => 'yes' }; $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; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/35-clean.t000644 000765 000024 00000013207 14211255371 016171 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use Data::Dumper; use IPC::Shareable; use IPC::Shareable::SharedMem; use Test::More; use Test::SharedFork; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; sub shm_cleaned { # --- shmread should barf if the segment has really been cleaned my $id = shift; my $data = ''; eval { shmread($id, $data, 0, 6) or die "$!" }; if ($@ && ($@ =~ /Invalid/ || $@ =~ /removed/)) { return 1; } return 0; } # create not sent in { my $ret = eval { my $s = tie(my $sv, 'IPC::Shareable', 'child_sv', { destroy => 0 }); 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 }; $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', 'test', { create => 1, destroy => 0 }; $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', 'test', { create => 1, destroy => 0 }; $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', 'test', { create => 1, destroy => 0 }; $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 $awake = 0; local $SIG{ALRM} = sub { $awake = 1 }; my $pid = fork; defined $pid or die "Cannot fork : $!"; if ($pid == 0) { # child sleep unless $awake; my $s = tie(my $sv, 'IPC::Shareable', 'kids', { destroy => 0 }); $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', 'kids', { create => 1, destroy => 0 }); kill ALRM => $pid; 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; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/30-lock_operation.t000644 000765 000024 00000002201 14211255322 020076 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use IPC::Shareable; use Test::More; use Test::SharedFork; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; 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', 'TEST', { destroy => 0 }); 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', 'TEST', { create => 1, destroy => 1 }) 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"; } IPC::Shareable::_end; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/17-attributes.t000644 000765 000024 00000003377 14211240006 017271 0ustar00stevestaff000000 000000 use warnings; use strict; use Data::Dumper; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; my $k = tie my $sv, 'IPC::Shareable', 'testing', {create => 1, destroy => 1}; my $attrs_tied = (tied $sv)->attributes; is ref $attrs_tied, 'HASH', "tied var attributes() returns a hash ref ok"; my $attrs = $k->attributes; is ref $attrs, 'HASH', "attributes() returns a hash ref ok"; my @attr_list = qw( warn exclusive key serializer size protected limit magic mode create owner graceful tidy destroy ); 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}, 'testing', "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->{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->{tidy}, 0, "tidy is set ok"; is $attrs->{destroy}, 1, "destroy is set ok"; is $k->attributes('no_exist'), undef, "attributes() on an undefined attr is undef"; IPC::Shareable::_end; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing; IPC-Shareable-1.13/t/67-exhaust_shm_slots.t000644 000765 000024 00000001555 14211255772 020700 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; my $mod = 'IPC::Shareable'; my $knot = tie my %hv, $mod, { create => 1, key => 1234, destroy => 1, }; my $ok = eval { for my $alpha ('a' .. 'z', 'A' .. 'Z') { for my $num (0 .. 100) { $hv{$alpha}->{$num} = $alpha; my $thing = $hv{$alpha}->{num}; delete $hv{$alpha}; } }; 1; }; is $ok, undef, "If we try to use all available shm slots, we croak()"; like $@, qr/No space left on device/, "...and error is sane"; IPC::Shareable->clean_up_all; IPC::Shareable::_end; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/61-seg_sem.t000644 000765 000024 00000002660 14211255641 016531 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use Data::Dumper; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; my $k = tie my $sv, 'IPC::Shareable', 'test', { create => 1, destroy => 1 }; # seg() my @seg_keys = qw( _id _key _flags _type _size ); my $knot_seg = $k->seg; my $tied_seg = (tied $sv)->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"; # sem() my $knot_sem = $k->sem(); my $tied_sem = (tied $sv)->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"; IPC::Shareable::_end; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/05-sv.t000644 000765 000024 00000001606 14211237466 015541 0ustar00stevestaff000000 000000 use warnings; use strict; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; tie my $sv, 'IPC::Shareable', {destroy => 1}; $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' }) or die ('this was not expected to die here'); $sv = $mod.'foo'; is $sv, $mod.'foo', "SCALAR regression store/fetch ok"; } IPC::Shareable::_end; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/63-nested_segs_tidy.t000644 000765 000024 00000005616 14211255663 020455 0ustar00stevestaff000000 000000 use warnings; use strict; use feature 'say'; use Data::Dumper; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; # array { my @test_data = ( [ 1, 2, 3, [ 26, [ 30, 31, ], ], ], ); tie my @a, 'IPC::Shareable', {create => 1, destroy => 1, tidy => 1}; my $initial_seg_count = seg_count(); is seg_count(), $initial_seg_count, "Initial array seg count ok"; $a[0] = [3]; is seg_count(), $initial_seg_count+1, "After initial aref add, seg count ok"; $a[0] = [1, 2]; is seg_count(), $initial_seg_count+1, "Adding a new aref to an existing element doesn't create a new seg ok"; $a[0] = [1, 2, 3]; is seg_count(), $initial_seg_count+1, "Same with repurposing the aref again"; $a[0] = [1, 2, 3, [26, [30, 31]]]; is seg_count(), $initial_seg_count+3, "Same with repurposing the aref again with nested"; is_deeply \@a, \@test_data, "Nested arrays compare ok"; IPC::Shareable->clean_up_all; } # hash { my %test_data = ( a => { a => 1, b => 2, c => 3, d => { z => 26, y => { yy => 25, }, }, } ); tie my %h, 'IPC::Shareable', {create => 1, destroy => 1, tidy => 1}; my $initial_seg_count = seg_count(); is seg_count(), $initial_seg_count, "Initial href seg count ok"; $h{a} = {a => 1}; is seg_count(), $initial_seg_count+1, "After initial href add, seg count ok"; $h{a} = {a => 1, b => 2}; is seg_count(), $initial_seg_count+1, "Adding a new href to an existing key doesn't create a new seg ok"; $h{a} = {a => 1, b => 2, c => 3}; is seg_count(), $initial_seg_count+1, "Same with repurposing the href again"; $h{a} = {a => 1, b => 2, c => 3, d => {z => 26}}; is seg_count(), $initial_seg_count+2, "Adding a new hash inside of existing does bump seg count"; $h{a} = {a => 1, b => 2, c => 3, d => {z => 26, y => {yy => 25}}}; is seg_count(), $initial_seg_count+4, "Adding a new hash inside of two level existing does bump seg count"; $h{a} = {a => 1, b => 2, c => 3, d => {z => 26, y => {yy => 25}}}; is seg_count(), $initial_seg_count+6, "Adding a new hash inside of two level existing twice does bump seg count"; is_deeply \%h, \%test_data, "Shared memory hash matches test data ok"; IPC::Shareable->clean_up_all; } IPC::Shareable::_end; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing; sub seg_count { my $count = `ipcs -m | wc -l`; chomp $count; $count =~ s/\s+//g; return $count; } IPC-Shareable-1.13/t/65-seg_size.t000644 000765 000024 00000004561 14211255726 016731 0ustar00stevestaff000000 000000 use warnings; use strict; use Config; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } if ($Config{ivsize} < 8) { plan skip_all => "This test script can't be run on a perl < 64-bit"; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; 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 }; 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 }; 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 { my $size_ok = eval { tie my $var, 'IPC::Shareable', { limit => 0, size => 999999999999, destroy => 1 }; 1; }; is $size_ok, undef, "We croak if size is greater than max RAM"; like $@, qr/Cannot allocate memory|Out of memory|Invalid argument/, "...and error is sane"; } my $k = tie my $sv, 'IPC::Shareable', { create => 1, destroy => 1, size => BYTES, }; 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; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/93-manifest.t000644 000765 000024 00000000451 14210441431 016707 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.13/t/40-ipcref.t000644 000765 000024 00000003632 14211255471 016355 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use IPC::Shareable; use Test::More; use Test::SharedFork; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; my $t = 1; my $ok = 1; my $awake = 0; local $SIG{ALRM} = sub { $awake = 1 }; my($av, $hv); my $pid = fork; defined $pid or die "Cannot fork : $!"; if ($pid == 0) { # child sleep unless $awake; tie $hv, 'IPC::Shareable', 'hash1', { destroy => 0 }; tie $av, 'IPC::Shareable', 'arry1', { destroy => 0 }; is $hv, 'baz', "child: HV is 'baz' ok"; is $av, 'bong', "child: AV is 'bong' ok"; $hv = { }; $av = [ ]; $av->[1]->[2] = 'beep'; $av->[2]->[3] = 'bang'; is $av->[1]->[2], 'beep', "child: nested AV 1 has 'beep' ok"; is $av->[2]->[3], 'bang', "child: nested AV 2 has 'bang' ok"; $hv->{blip}->{blarp} = 'blurp'; $hv->{flip}->{flop} = 'flurp'; is $hv->{blip}->{blarp}, 'blurp', "child: nested HV 1 is 'blurp' ok"; is $hv->{flip}->{flop}, 'flurp', "child: nested HV 2 is 'flurp' ok"; exit; } else { # parent tie $hv, 'IPC::Shareable', 'hash1', { create => 1, destroy => 1 }; tie $av, 'IPC::Shareable', 'arry1', { create => 1, destroy => 1 }; $hv = 'baz'; $av = 'bong'; kill ALRM => $pid; waitpid($pid, 0); is $hv->{blip}->{blarp}, 'blurp', "parent: nested HV 1 is 'blurp' ok"; is $hv->{flip}->{flop}, 'flurp', "parent: nested HV 2 is 'flurp' ok"; is $av->[1]->[2], 'beep', "parent: nested AV 1 has 'beep' ok"; is $av->[2]->[3], 'bang', "parent: nested AV 2 has 'bang' ok"; IPC::Shareable->clean_up_all; is defined $av, '', "AV cleaned after clean_up_all()"; is defined $hv, '', "HV cleaned after clean_up_all()"; } IPC::Shareable::_end; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/31-lock_semaphore.t000644 000765 000024 00000003211 14211255344 020070 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use IPC::Shareable qw(:lock); use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; my $t = tie my $sv, 'IPC::Shareable', { create => 1, key => 'data', destroy => 1 }; 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; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/91-pod_linkcheck.t000644 000765 000024 00000000464 14210441431 017700 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.13/t/92-pod.t000644 000765 000024 00000000504 14210441431 015661 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.13/t/80-exceptions.t000644 000765 000024 00000001671 14211256153 017271 0ustar00stevestaff000000 000000 use warnings; use strict; use Test::More; #plan skip_all => "TEST FILE NOT READY"; use IPC::Shareable; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; { # exclusive duplicate my $opts = { key => 1234, create => 1, exclusive => 1, destroy => 1, mode => 0600, size => 999, }; 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/ERROR:.*File exists/, "...and error message is sane"; } IPC::Shareable::_end; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/83-clean_protected.t000644 000765 000024 00000004431 14211256236 020245 0ustar00stevestaff000000 000000 use warnings; use strict; use Data::Dumper; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; 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 => 100, create => 1, exclusive => 1, destroy => 1, protected => 500, }; $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 => 10, create => 1, exclusive => 1, destroy => 1, protected => $protect_lock, }; tie my %u, 'IPC::Shareable', { key => 20, create => 1, exclusive => 1, destroy => 1, }; $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; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/t/20-ref.t000644 000765 000024 00000003724 14211240026 015647 0ustar00stevestaff000000 000000 use warnings; use strict; use Carp; use Data::Dumper; use IPC::Shareable; use Test::More; BEGIN { if (! $ENV{CI_TESTING}) { plan skip_all => "Not on a legit CI platform..."; } } warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; # scalar ref tie my $sv, 'IPC::Shareable', { destroy => 1 }; my $ref = 'ref'; $sv = \$ref; is $$sv, $ref, "an SV can be assigned a reference to another scalar"; # array ref $sv = [ 0 .. 9 ]; is ref($sv), 'ARRAY', "SV contains an aref ok"; for (0 .. 9) { is $sv->[$_], $_, "SV aref properly contains $_ at elem $_"; } # 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', "SV contains an href ok"; while (my($k, $v) = each %check){ is $sv->{$k}, $v, "SV href key $k contains value $v ok"; } # multiple refs tie my @av, 'IPC::Shareable'; $av[0] = { foo => 'bar', baz => 'bash' }; $av[1] = [ 0 .. 9 ]; is ref($av[0]), 'HASH', "AV elem 0 is a hash"; is ref($av[1]), 'ARRAY', "AV elem 1 is an array"; is $av[0]->{foo}, 'bar', "AV->HV contains valid value in key 'foo'"; is $av[0]->{baz}, 'bash', "AV->HV contains valid value in key 'baz'"; for (0 .. 9) { is $av[1]->[$_], $_, "AV[1]->[$_] == $_ ok"; } tie my %hv, 'IPC::Shareable'; for ('a' .. 'z') { $hv{lower}->{$_} = $_; $hv{upper}->{$_} = uc; } for ('a' .. 'z') { is $hv{lower}->{$_}, $_, "HV{lower}{$_} set to $_ ok"; is $hv{upper}->{$_}, uc $_, "HV{upper}{$_} set to uppercase $_ ok"; } IPC::Shareable->clean_up_all; # deeply nested tie $sv, 'IPC::Shareable', { destroy => 1 }; $sv->{this}->{is}->{nested}->{deeply}->[0]->[1]->[2] = 'found'; is $sv->{this}->{is}->{nested}->{deeply}->[0]->[1]->[2], 'found', "crazy deep nested struct ok"; IPC::Shareable->clean_up_all; IPC::Shareable::_end; warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS}; done_testing(); IPC-Shareable-1.13/docs/Shared Memory Configuration.txt000644 000765 000024 00000003052 14211032176 023143 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. You can modify the kern.sysv parameters in the below file to your liking, then put the file into a ""/Library/LaunchDaemons/SharedMemory.plist" file and reboot. --- Label shmemsetup UserName root GroupName wheel ProgramArguments /usr/sbin/sysctl -w kern.sysv.shmmax=4194304 kern.sysv.shmmni=32 kern.sysv.shmseg=8 kern.sysv.shmall=1024 kern.sysv.shmmin=1 KeepAlive RunAtLoad