Commit 61eb0d0c2d3117e36304a6f5b3799a8ce984ecc2 - libipc-shareable-perl

+23

-0

Changes less more

0	0	Revision history for Perl extension IPC::Shareable.
	1
	2	1.12 2022-03-13
	3	- Add tests in t/07-new.t to test how using tied() against a dereferenced
	4	variable returned from new() allows access to the underlying
	5	IPC::Shareable object
	6	- Reworked how spawn() and unspawn() manage things internally
	7	- POD updates, fixes and clarifications
	8	- Removed spawn() and unspawn(). There's really no need for these as one
	9	can simply create but not destroy
	10
	11	1.11 2022-03-07
	12	- Fix certain tests so they don't throw if we bail early
	13
	14	1.10 2022-03-07
	15	- Fix issue where if segments were created underneath of a parent by an
	16	external process other than the process that created the parent, the
	17	global register wasn't being updated, therefore those segments weren't
	18	being removed when calling clean_up_all()
	19	- All test files now check number of segments before and after the entire
	20	script has run, verifying that all segments were cleaned up ok
	21	- The test suite itself in its entirety makes sure that all segments
	22	created during the suite run are cleaned up properly
	23	- Added CI_TESTING=1 to coverage CI tests
1	24
2	25	1.09 2022-03-06
3	26	- Made 81-fork_dup_rand_keys.t developer only (but still need to figure out

+2

-7

MANIFEST less more

7	7	CREDITS
8	8	DISCLAIMER
9	9	'docs/Shared Memory Configuration.txt'
	10	examples/new.pl
10	11	lib/IPC/Shareable.pm
11	12	lib/IPC/Shareable/SharedMem.pm
12	13	Makefile.PL

40	41	t/65-seg_size.t
41	42	t/66-size_exceeded.t
42	43	t/67-exhaust_shm_slots.t
43		t/71-unspawn.t
44		t/72-unspawn_destroy.t
45	44	t/75-graceful.t
46	45	t/76-singleton.t
47	46	t/77-singleton_warn.t

49	48	t/81-fork_dup_rand_keys.t
50	49	t/82-sig_child_ignore.t
51	50	t/83-clean_protected.t
52		t/85-spawn_object_contains_data.t
53		t/86-unspawn_object_contains_data.t
54	51	t/90-pod_coverage.t
55	52	t/91-pod_linkcheck.t
56	53	t/92-pod.t
57	54	t/93-manifest.t
58		t/_spawn
59		t/_spawn_class
60		t/SpawnTest.pm
	55	t/99-end.t
61	56	testing/new_one.pl
62	57	testing/new_two.pl
63	58	testing/one_deep_hash.pl

+1

-1

META.json less more

53	53	"web" : "https://github.com/stevieb9/ipc-shareable"
54	54	}
55	55	},
56		"version" : "1.09",
	56	"version" : "1.12",
57	57	"x_serialization_backend" : "JSON::PP version 4.04"
58	58	}

+1

-1

META.yml less more

28	28	resources:
29	29	bugtracker: https://github.com/stevieb9/ipc-shareable/issues
30	30	repository: https://github.com/stevieb9/ipc-shareable.git
31		version: '1.09'
	31	version: '1.12'
32	32	x_serialization_backend: 'CPAN::Meta::YAML version 0.018'

+22

-0

examples/new.pl less more

	0	use warnings;
	1	use strict;
	2	use feature 'say';
	3
	4	use Data::Dumper;
	5	use IPC::Shareable;
	6
	7	say "Before: " . IPC::Shareable::ipcs;
	8
	9	my $h = IPC::Shareable->new(
	10	key => 'blah',
	11	create => 1,
	12	destroy => 1
	13	);
	14
	15	$h->{one}{two} = 'hello, world!';
	16	$h->{one}{three}{four} = 1;
	17
	18	print Dumper $h;
	19
	20	IPC::Shareable::_end;
	21	say "After: " . IPC::Shareable::ipcs;

+1

-1

lib/IPC/Shareable/SharedMem.pm less more

5	5	use Carp qw(carp croak confess);
6	6	use IPC::SysV qw(IPC_RMID);
7	7
8		our $VERSION = '1.09';
	8	our $VERSION = '1.12';
9	9
10	10	use constant DEBUGGING => ($ENV{SHM_DEBUG} or 0);
11	11

+115

-180

lib/IPC/Shareable.pm less more

20	20	use String::CRC32;
21	21	use Storable 0.6 qw(freeze thaw);
22	22
23		our $VERSION = '1.09';
	23	our $VERSION = '1.12';
24	24
25	25	use constant {
26	26	LOCK_SH => 1,

125	125	sub STORE {
126	126	my $knot = shift;
127	127
128		my $sid = $knot->seg->{_id};
129
130		$global_register{$sid} \|\|= $knot;
	128	if (! exists $global_register{$knot->seg->id}) {
	129	$global_register{$knot->seg->id} = $knot;
	130	}
131	131
132	132	$knot->{_data} = $knot->_decode($knot->seg) unless ($knot->{_lock});
133	133

163	163	sub FETCH {
164	164	my $knot = shift;
165	165
166		my $sid = $knot->seg->{_id};
167
168		$global_register{$sid} \|\|= $knot;
	166	if (! exists $global_register{$knot->seg->id}) {
	167	$global_register{$knot->seg->id} = $knot;
	168	}
169	169
170	170	my $data;
171	171	if ($knot->{_lock} \|\| $knot->{_iterating}) {

285	285	sub PUSH {
286	286	my $knot = shift;
287	287
288		$global_register{$knot->seg->id} \|\|= $knot;
	288	if (! exists $global_register{$knot->seg->id}) {
	289	$global_register{$knot->seg->id} = $knot;
	290	}
	291
289	292	$knot->{_data} = $knot->_decode($knot->seg, $knot->{_data}) unless $knot->{_lock};
290	293
291	294	push @{$knot->{_data}}, @_;

397	400	}
398	401	}
399	402	sub global_register {
	403	# This is a ridiculous way to do this, but if we don't call Dumper, hashes
	404	# that are created in a separate process than the parent hash don't
	405	# show up properly in the global register. t/81
	406
	407	local $SIG{__WARN__} = sub {
	408	my ($warning) = @_;
	409	if ($warning !~ /hash after insertion/) {
	410	warn $warning;
	411	}
	412	};
	413
	414	Dumper \%global_register;
	415
400	416	return \%global_register;
401	417	}
402	418	sub process_register {

418	434	sub ipcs {
419	435	my $count = `ipcs -m \| wc -l`;
420	436	chomp $count;
421		return $count;
422		}
423		sub spawn {
424		my ($knot, %opts) = @_;
425
426		croak "spawn() requires a key/glue sent in..." if ! defined $opts{key};
427
428		$opts{mode} = 0666 if ! defined $opts{mode};
429
430		$SIG{CHLD} = 'IGNORE';
431
432		_spawn(
433		key => $opts{key},
434		mode => $opts{mode},
435		);
436		}
437		sub _spawn {
438		my (%opts) = @_;
439
440		my $pid = fork;
441		return if $pid;
442
443		if (! $pid) {
444		tie my %h, 'IPC::Shareable', {
445		key => $opts{key},
446		create => 1,
447		#exclusive => 1,
448		destroy => $opts{destroy},
449		mode => $opts{mode},
450		};
451
452		$h{__ipc}->{run} = 1;
453
454		while (1) {
455		local $SIG{__WARN__} = sub {};
456		last if ! defined $h{__ipc};
457		last if ! $h{__ipc}->{run};
458		}
459
460		IPC::Shareable->clean_up_all if $opts{destroy};
461		exit 0;
462		}
463		}
464		sub unspawn {
465		shift;
466		my ($key, $destroy) = @_;
467
468		$destroy \|\|= 0;
469
470		tie my %h, 'IPC::Shareable', {
471		key => $key,
472		destroy => $destroy,
473		mode => 0666,
474		};
475
476		$h{__ipc}->{run} = 0;
477
478		$SIG{CHLD} = undef;
479
480		sleep 1;
481
482		IPC::Shareable->clean_up_all if $destroy;
	437	return int($count);
483	438	}
484	439	sub lock {
485	440	my ($knot, $flags) = @_;

525	480	sub clean_up {
526	481	my $class = shift;
527	482
528		for my $s (values %process_register) {
	483	for my $id (keys %process_register) {
	484	my $s = $process_register{$id};
529	485	next unless $s->attributes('owner') == $$;
530	486	next if $s->attributes('protected');
531	487	remove($s);

533	489	}
534	490	sub clean_up_all {
535	491	my $class = shift;
536		for my $s (values %process_register) {
537		next if $s->attributes('protected');
538		remove($s);
539		}
540
541		for my $s (values %global_register) {
	492
	493	my $global_register = __PACKAGE__->global_register;
	494
	495	for my $id (keys %$global_register) {
	496	my $s = $global_register->{$id};
542	497	next if $s->attributes('protected');
543	498	remove($s);
544	499	}

562	517	"clean_up_protected() \$protect_key must be an integer. You sent $protect_key";
563	518	}
564	519
565		for my $s (values %global_register) {
	520	my $global_register = __PACKAGE__->global_register;
	521
	522	for my $id (keys %$global_register) {
	523	my $s = $global_register->{$id};
566	524	my $stored_key = $s->attributes('protected');
567	525
568	526	if ($stored_key && $stored_key == $protect_key) {

615	573	}
616	574
617	575	END {
	576	_end();
	577	}
	578
	579	# --- Private methods below
	580
	581	sub _encode {
	582	my ($knot, $seg, $data) = @_;
	583
	584	my $serializer = $knot->attributes('serializer');
	585
	586	if ($serializer eq 'storable') {
	587	return _freeze($seg, $data);
	588	}
	589	elsif ($serializer eq 'json'){
	590	return _encode_json($seg, $data);
	591	}
	592
	593	return undef;
	594	}
	595	sub _end {
618	596	for my $s (values %process_register) {
619	597	unlock($s);
620	598	next if $s->attributes('protected');

622	600	next if $s->attributes('owner') != $$;
623	601	remove($s);
624	602	}
625		}
626
627		# --- Private methods below
628
629		sub _encode {
630		my ($knot, $seg, $data) = @_;
631
632		my $serializer = $knot->attributes('serializer');
633
634		if ($serializer eq 'storable') {
635		return _freeze($seg, $data);
636		}
637		elsif ($serializer eq 'json'){
638		return _encode_json($seg, $data);
639		}
640
641		return undef;
642	603	}
643	604	sub _decode {
644	605	my ($knot, $seg) = @_;

813	774	$knot->{_data} = _thaw($seg);
814	775
815	776	if ($sem->getval(SEM_MARKER) != SHM_EXISTS) {
816		$global_register{$knot->seg->id} \|\|= $knot;
	777
	778	if (! exists $global_register{$knot->seg->id}) {
	779	$global_register{$knot->seg->id} = $knot;
	780	}
	781
817	782	$process_register{$knot->seg->id} \|\|= $knot;
818	783	if (! $sem->setval(SEM_MARKER, SHM_EXISTS)){
819	784	croak "Couldn't set semaphore during object creation: $!";

1119	1084	tie ARRAY, 'IPC::Shareable', OPTIONS;
1120	1085	tie HASH, 'IPC::Shareable', OPTIONS;
1121	1086
1122		(tied VARIABLE)->lock;
1123		(tied VARIABLE)->unlock;
1124
1125		(tied VARIABLE)->lock(LOCK_SH\|LOCK_NB)
	1087	tied(VARIABLE)->lock;
	1088	tied(VARIABLE)->unlock;
	1089
	1090	tied(VARIABLE)->lock(LOCK_SH\|LOCK_NB)
1126	1091	or print "Resource unavailable\n";
1127	1092
1128		my $segment = (tied VARIABLE)->seg;
1129		my $semaphore = (tied VARIABLE)->sem;
1130
1131		(tied VARIABLE)->remove;
	1093	my $segment = tied(VARIABLE)->seg;
	1094	my $semaphore = tied(VARIABLE)->sem;
	1095
	1096	tied(VARIABLE)->remove;
1132	1097
1133	1098	IPC::Shareable::clean_up;
1134	1099	IPC::Shareable::clean_up_all;

1140	1105
1141	1106	# Get the actual IPC::Shareable tied object
1142	1107
1143		my $knot = tied VARIABLE; # Dereference first if necessary
	1108	my $knot = tied(VARIABLE); # Dereference first if using a tied reference
1144	1109
1145	1110	=head1 DESCRIPTION
1146	1111

1263	1228	Set this to a specific integer so we can pass the value to any child objects
1264	1229	created under the main one.
1265	1230
1266		To clean up protected objects, call C<< (tied %object)->clean_protected >>.
	1231	To clean up protected objects, call
	1232	C<< (tied %object)->clean_up_protected(integer) >>, where 'integer' is the
	1233	value you set the C<protected> option to. You can call this cleanup routine in
	1234	the script you created the segment, or anywhere else, at any time.
1267	1235
1268	1236	Default: B<0>
1269	1237

1321	1289	create => 0,
1322	1290	exclusive => 0,
1323	1291	mode => 0666,
1324		size => IPC::Shareable::SHM_BUFSIZ(),
	1292	size => IPC::Shareable::SHM_BUFSIZ(), # 65536
1325	1293	protected => 0,
1326	1294	limit => 1,
1327	1295	destroy => 0,

1336	1304
1337	1305	Instantiates and returns a reference to a hash backed by shared memory.
1338	1306
	1307	my $href = IPC::Shareable->new(key => "testing", create => 1);
	1308
	1309	$href=>{a} = 1;
	1310
	1311	# Call tied() on the dereferenced variable to access object methods
	1312	# and information
	1313
	1314	tied(%$href)->ipcs;
	1315
1339	1316	Parameters:
1340	1317
1341	1318	Hash, Optional: See the L</OPTIONS> section for a list of all available options.
1342		Most often, you'll want to send in the B<key>, B<create> and B<destroy> options.
	1319	Most often, you'll want to send in the B<key> and B<create> options.
1343	1320
1344	1321	It is possible to get a reference to an array or scalar as well. Simply send in
1345	1322	either C<< var = > 'ARRAY' >> or C<< var => 'SCALAR' >> to do so.

1368	1345	=head2 ipcs
1369	1346
1370	1347	Returns the number of instantiated shared memory segments that currently exist
1371		on the system.
	1348	on the system. This isn't precise; it simply does a C<wc -l> line count on your
	1349	system's C<ipcs -m> call. It is guaranteed though to produce reliable results.
1372	1350
1373	1351	Return: Integer
1374
1375		=head2 spawn(%opts)
1376
1377		Spawns a forked process running in the background that holds the shared memory
1378		segments backing your variable open.
1379
1380		Parameters:
1381
1382		Paremters are sent in as a hash.
1383
1384		key => $glue
1385
1386		Mandatory, String/Integer: The glue that you will be accessing your data as.
1387
1388		mode => 0666
1389
1390		Optional, Integer: The read/write permissions on the variable. Defaults to
1391		C<0666>.
1392
1393		Example:
1394
1395		use IPC::Shareable;
1396
1397		# The following line sets things up and returns
1398
1399		IPC::Shareable->spawn(key => 'GLUE STRING');
1400
1401		Now, either within the same script, or any other script on the system, your
1402		data will be available at the key/glue C<GLUE STRING>. Call
1403		L<unspawn()\|/unspawn($key, $destroy)> to remove it.
1404
1405		=head2 unspawn($key, $destroy)
1406
1407		This method will kill off the background process created with
1408		L<spawn()\|/spawn(%opts)>.
1409
1410		Parameters:
1411
1412		$key
1413
1414		Mandatory, String/Integer: The glue (aka key) used in the call to C<spawn()>.
1415
1416		$destroy
1417
1418		Optional, Bool. If set to a true value, we will remove all semaphores and memory
1419		segments related to your data, thus removing the data in its entirety. If not
1420		set to a true value, we'll leave the memory segments in place, and you'll be
1421		able to re-attach to the data at any time. Defaults to false (C<0>).
1422	1352
1423	1353	=head2 lock($flags)
1424	1354

1427	1357	read/write lock is obtained. Acceptable values for C<$flags> are
1428	1358	the same as for the C<flock()> system call.
1429	1359
1430		Returns C<true> on success, and C<undef> on error. For non-blocking calls
	1360	Returns C<true> on success, and C<undef> on error. For non-blocking calls
1431	1361	(see below), the method returns C<0> if it would have blocked.
1432	1362
1433	1363	Obtain an exclusive lock like this:
1434	1364
1435	1365	tied(%var)->lock(LOCK_EX); # same as default
1436	1366
1437		Only one process can hold an exclusive lock on the shared memory at
1438		a given time.
	1367	Only one process can hold an exclusive lock on the shared memory at a given
	1368	time.
1439	1369
1440	1370	Obtain a shared (read) lock:
1441	1371

1459	1389	details.
1460	1390
1461	1391	Locks are inherited through forks, which means that two processes actually
1462		can possess an exclusive lock at the same time. Don't do that.
	1392	can possess an exclusive lock at the same time. Don't do that.
1463	1393
1464	1394	The constants C<LOCK_EX>, C<LOCK_SH>, C<LOCK_NB>, and C<LOCK_UN> are available
1465	1395	for import using any of the following export tags:

1522	1452
1523	1453	IPC::Shareable provides methods to implement application-level
1524	1454	advisory locking of the shared data structures. These methods are
1525		called C<shlock()> and C<shunlock()>. To use them you must first get the
	1455	called C<lock()> and C<unlock()>. To use them you must first get the
1526	1456	object underlying the tied variable, either by saving the return
1527	1457	value of the original call to C<tie()> or by using the built-in C<tied()>
1528	1458	function.

1547	1477	also get shared locks or attempt to get a lock without blocking.
1548	1478
1549	1479	L<IPC::Shareable> makes the constants C<LOCK_EX>, C<LOCK_SH>, C<LOCK_UN>, and
1550		C<LOCK_NB> exportable to your address space with the export tags
1551		C<:lock>, C<:flock>, or C<:all>. The values should be the same as
1552		the standard C<flock> option arguments.
	1480	C<LOCK_NB> exportable to your address space with the export tags C<:lock>,
	1481	C<:flock>, or C<:all>. The values should be the same as the standard C<flock>
	1482	option arguments.
1553	1483
1554	1484	if (tied(%hash)->lock(LOCK_SH\|LOCK_NB)){
1555	1485	print "The value is $hash{a}\n";
1556	1486	tied(%hash)->unlock;
1557	1487	} else {
1558		print "Another process has an exlusive lock.\n";
	1488	print "Another process has an exclusive lock.\n";
1559	1489	}
1560	1490
1561	1491	If no argument is provided to C<lock>, it defaults to C<LOCK_EX>.

1568	1498
1569	1499	Using the advisory locks can speed up processes that are doing several writes/
1570	1500	reads at the same time.
1571
1572		=head1 REFERENCES
1573
1574		Although references can reside within a shared data structure, the tied variable
1575		can not be a reference itself.
1576	1501
1577	1502	=head1 DESTRUCTION
1578	1503

1654	1579	method, you must send that integer in as a parameter so we know which segments
1655	1580	to clean up.
1656	1581
	1582	my $protect_key = 93432;
	1583
	1584	IPC::Shareable->clean_up_protected($protect_key);
	1585
	1586	# or
	1587
	1588	tied($var)->clean_up_protected($protect_key;
	1589
	1590	# or
	1591
	1592	$knot->clean_up_protected($protect_key)
	1593
1657	1594	Parameters:
1658	1595
1659	1596	$protect_key

1682	1619
1683	1620	=item 1
1684	1621
1685		If the process has been smoked by an untrapped signal, the binding
1686		will remain in shared memory. If you're cautious, you might try
	1622	If the process has been smoked by an untrapped signal, the binding will remain
	1623	in shared memory. If you're cautious, you might try:
1687	1624
1688	1625	$SIG{INT} = \&catch_int;
1689	1626	sub catch_int {

1709	1646	signals. Under normal circumstances, C<IPC::Shareable>'s C<END> method
1710	1647	unlocks any locked variables when the process exits. However, if an
1711	1648	untrapped signal is received while a process holds an exclusive lock,
1712		C<DESTROY> will not be called and the lock may be maintained even though
	1649	C<END> will not be called and the lock may be maintained even though
1713	1650	the process has exited. If this scares you, you might be better off
1714	1651	implementing your own locking methods.
1715	1652

1731	1668	There is a program called C<ipcs>(1/8) (and C<ipcrm>(1/8)) that is
1732	1669	available on at least Solaris and Linux that might be useful for
1733	1670	cleaning moribund shared memory segments or semaphore sets produced
1734		by bugs in either IPC::Shareable or applications using it.
	1671	by bugs in either L<IPC::Shareable> or applications using it.
1735	1672
1736	1673	Examples:
1737	1674

1769	1706	iterating over a hash tied to L<IPC::Shareable>, but we attempt this
1770	1707	optimization if you do not).
1771	1708
1772		The C<fetch>/C<thaw> operation is performed
	1709	For tied hashes, the C<fetch>/C<thaw> operation is performed
1773	1710	when the first key is accessed. Subsequent key and and value
1774	1711	accesses are done without accessing shared memory. Doing an
1775	1712	assignment to the hash or fetching another value between key
1776		accesses causes the hash to be replaced from shared memory. The
	1713	accesses causes the hash to be replaced from shared memory. The
1777	1714	state of the iterator in this case is not defined by the Perl
1778		documentation. Caveat Emptor.
	1715	documentation. Caveat Emptor.
1779	1716
1780	1717	=back
1781	1718

1801	1738
1802	1739	L<perltie>, L<Storable>, C<shmget>, C<ipcs>, C<ipcrm> and other SysV IPC manual
1803	1740	pages.
1804
1805

+31

-6

t/00-base.t less more

3	3	use Data::Dumper;
4	4	use Test::More;
5	5
6		BEGIN { use_ok('IPC::Shareable') };
	6	BEGIN {
	7	if (!$ENV{CI_TESTING}) {
	8	plan skip_all => "Not on a valid CI platform...";
	9	}
	10	use_ok('IPC::Shareable');
	11	};
7	12
8		my $a = tie my $x, 'IPC::Shareable';
9		my $b = tie my $y, 'IPC::Shareable', {create => 1, destroy => 1};
	13	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	14	my $segs = IPC::Shareable::ipcs();
	15	print "Starting with $segs segments\n";
10	16
11		is $a->{_key}, 0, "tie with no glue or options is IPC_PRIVATE ok";
12		is $b->{_key}, 0, "tie with no glue but with options is IPC_PRIVATE ok";
	17	is $segs, $segs, "Initial test ok";
13	18
14		done_testing();
	19	{
	20	my $a = tie my $x, 'IPC::Shareable';
	21	my $b = tie my $y, 'IPC::Shareable', { create => 1, destroy => 1 };
	22
	23	is $a->{_key}, 0, "tie with no glue or options is IPC_PRIVATE ok";
	24	is $b->{_key}, 0, "tie with no glue but with options is IPC_PRIVATE ok";
	25
	26	$a->remove;
	27
	28	# Store existing segments in a shared hash to test against
	29	# at conclusion of test suite run
	30
	31	tie my %store, 'IPC::Shareable', { key => 'async_tests', create => 1 };
	32
	33	$store{segs} = $segs;
	34	}
	35
	36	IPC::Shareable::_end;
	37	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	38
	39	done_testing();⏎

+6

-0

t/02-create.t less more

9	9	}
10	10	}
11	11
	12	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	13
12	14	my $ok = eval {
13	15	tie my $sv, 'IPC::Shareable', {key => 'test02', destroy => 1};
14	16	1;

17	19	is $ok, undef, "We croak ok if create is not set and segment doesn't yet exist";
18	20	like $@, qr/Could not acquire/, "...and error is sane.";
19	21
	22	IPC::Shareable::_end;
	23
	24	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	25
20	26	done_testing;
21	27

+7

-0

t/04-key.t less more

10	10	plan skip_all => "Not on a legit CI platform...";
11	11	}
12	12	}
	13
	14	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
13	15
14	16	# deprecated string key param
15	17	{

177	179	qr/available key after 10 tries/,
178	180	"...the error shows it attempted multiple times";
179	181	}
	182
	183	IPC::Shareable::_end;
	184
	185	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	186
180	187	done_testing();

+5

-0

t/05-sv.t less more

8	8	plan skip_all => "Not on a legit CI platform...";
9	9	}
10	10	}
	11
	12	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
11	13
12	14	tie my $sv, 'IPC::Shareable', {destroy => 1};
13	15

29	31	is $sv, $mod.'foo', "SCALAR regression store/fetch ok";
30	32	}
31	33
	34	IPC::Shareable::_end;
	35	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	36
32	37	done_testing();

+12

-0

t/07-new.t less more

10	10	plan skip_all => "Not on a legit CI platform...";
11	11	}
12	12	}
	13
	14	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
13	15
14	16	my $mod = 'IPC::Shareable';
15	17

39	41	# parent
40	42
41	43	my $ph = $mod->new(key => 'hash2', create => 1, destroy => 1);
	44	like tied(%$ph), qr/IPC::Shareable/, "new() tied hash is proper object ok";
	45	like tied(%$ph)->can('ipcs'), qr/CODE/, "...and it can call its methods ok";
	46
42	47	my $pa = $mod->new(key => 'array2', create => 1, destroy => 1, var => 'ARRAY');
	48	like tied(@$pa), qr/IPC::Shareable/, "new() tied array is proper object ok";
	49	like tied(@$pa)->can('ipcs'), qr/CODE/, "...and it can call its methods ok";
	50
43	51	my $ps = $mod->new(key => 'scalar2', create => 1, destroy => 1, var => 'SCALAR');
	52	like tied($$ps), qr/IPC::Shareable/, "new() tied scalar is proper object ok";
	53	like tied($$ps)->can('ipcs'), qr/CODE/, "...and it can call its methods ok";
44	54
45	55	kill ALRM => $pid;
46	56	waitpid($pid, 0);

60	70
61	71	IPC::Shareable->clean_up_all;
62	72
	73	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	74
63	75	done_testing();
64	76	}
65	77

+5

-0

t/08-new_tied_obj.t less more

9	9	plan skip_all => "Not on a legit CI platform...";
10	10	}
11	11	}
	12
	13	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
12	14
13	15	my $mod = 'IPC::Shareable';
14	16

23	25	is ref $k, 'IPC::Shareable', "tied() returns a proper IPC::Shareable object ok";
24	26	is exists $k->{attributes}, 1, "...and it has proper attributes ok";
25	27
	28	IPC::Shareable::_end;
	29	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	30
26	31	done_testing();

+5

-0

t/10-av.t less more

8	8	plan skip_all => "Not on a legit CI platform...";
9	9	}
10	10	}
	11
	12	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
11	13
12	14	tie my @av, 'IPC::Shareable', { destroy => 1 };
13	15

63	65	is $gone[0], 'fie', "splice 3 ok";
64	66	is $gone[1], 'foe', "splice 4 ok";
65	67
	68	IPC::Shareable::_end;
	69	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	70
66	71	done_testing();

+5

-0

t/15-hv.t less more

9	9	plan skip_all => "Not on a legit CI platform...";
10	10	}
11	11	}
	12
	13	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
12	14
13	15	my $mod = 'IPC::Shareable';
14	16

78	80
79	81	is %hv, '', "hash deleted after clean_up()";
80	82
	83	IPC::Shareable::_end;
	84	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	85
81	86	done_testing();
82	87
83	88

+5

-0

t/17-attributes.t less more

9	9	plan skip_all => "Not on a legit CI platform...";
10	10	}
11	11	}
	12
	13	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
12	14
13	15	my $k = tie my $sv, 'IPC::Shareable', 'testing', {create => 1, destroy => 1};
14	16

59	61
60	62	is $k->attributes('no_exist'), undef, "attributes() on an undefined attr is undef";
61	63
	64	IPC::Shareable::_end;
	65	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	66
62	67	done_testing;

+5

-0

t/20-ref.t less more

10	10	plan skip_all => "Not on a legit CI platform...";
11	11	}
12	12	}
	13
	14	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
13	15
14	16	# scalar ref
15	17

89	91
90	92	IPC::Shareable->clean_up_all;
91	93
	94	IPC::Shareable::_end;
	95	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	96
92	97	done_testing();

+5

-0

t/25-ipc.t less more

10	10	plan skip_all => "Not on a legit CI platform...";
11	11	}
12	12	}
	13
	14	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
13	15
14	16	my $awake = 0;
15	17	local $SIG{ALRM} = sub { $awake = 1 };

45	47	IPC::Shareable->clean_up_all;
46	48	}
47	49
	50	IPC::Shareable::_end;
	51	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	52
48	53	done_testing();

+5

-0

t/30-lock_operation.t less more

10	10	plan skip_all => "Not on a legit CI platform...";
11	11	}
12	12	}
	13
	14	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
13	15
14	16	my $sv;
15	17

51	53	is $sv, 200, "in parent: locked and updated SV to 200";
52	54	}
53	55
	56	IPC::Shareable::_end;
	57	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	58
54	59	done_testing();

+5

-0

t/31-lock_semaphore.t less more

9	9	plan skip_all => "Not on a legit CI platform...";
10	10	}
11	11	}
	12
	13	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
12	14
13	15	my $t = tie my $sv, 'IPC::Shareable', {
14	16	create => 1,

66	68	is $t->sem->getval($_), $none[$_], "after share nb lock unlock, sem $_ set to $none[$_] ok";
67	69	}
68	70
	71	IPC::Shareable::_end;
	72	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	73
69	74	done_testing();

+5

-0

t/35-clean.t less more

13	13	}
14	14	}
15	15
	16	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	17
16	18	sub shm_cleaned {
17	19	# --- shmread should barf if the segment has really been cleaned
18	20	my $id = shift;

192	194	}
193	195	}
194	196
	197	IPC::Shareable::_end;
	198	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	199
195	200	done_testing();

+5

-0

t/36-ipcav.t less more

9	9	plan skip_all => "Not on a legit CI platform...";
10	10	}
11	11	}
	12
	13	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
12	14
13	15	my $t = 1;
14	16	my $ok = 1;

77	79	IPC::Shareable->clean_up_all;
78	80	}
79	81
	82	IPC::Shareable::_end;
	83	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	84
80	85	done_testing();

+5

-0

t/38-ipchv.t less more

9	9	plan skip_all => "Not on a legit CI platform...";
10	10	}
11	11	}
	12
	13	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
12	14
13	15	plan tests => 8;
14	16

90	92	}
91	93	}
92	94
	95	IPC::Shareable::_end;
	96	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	97
93	98	#done_testing();

+5

-0

t/40-ipcref.t less more

10	10	plan skip_all => "Not on a legit CI platform...";
11	11	}
12	12	}
	13
	14	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
13	15
14	16	my $t = 1;
15	17	my $ok = 1;

74	76	is defined $hv, '', "HV cleaned after clean_up_all()";
75	77	}
76	78
	79	IPC::Shareable::_end;
	80	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	81
77	82	done_testing();

+5

-0

t/45-obj.t less more

9	9	plan skip_all => "Not on a legit CI platform...";
10	10	}
11	11	}
	12
	13	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
12	14
13	15	my $t = 1;
14	16	my $ok = 1;

48	50	is $d->first('foo'), 'foo', "shared obj first() returns ok, again";
49	51	is $d->second('bar'), 'bar', "shared obj second() returns ok, again";
50	52
	53	IPC::Shareable::_end;
	54	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	55
51	56	done_testing();
52	57

+5

-0

t/50-ipcobj.t less more

9	9	plan skip_all => "Not on a legit CI platform...";
10	10	}
11	11	}
	12
	13	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
12	14
13	15	my $t = 1;
14	16	my $ok = 1;

87	89	is defined $d, '', "parent: after clean_up_all(), everything's gone";
88	90	}
89	91
	92	IPC::Shareable::_end;
	93	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	94
90	95	done_testing();
91	96

+5

-0

t/55-lsync.t less more

11	11	plan skip_all => "Not on a legit CI platform...";
12	12	}
13	13	}
	14
	15	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
14	16
15	17	my $t = 1;
16	18	my $ok = 1;

80	82	is %thash, '', "data cleaned up after clean_up_all()";
81	83	}
82	84
	85	IPC::Shareable::_end;
	86	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	87
83	88	done_testing();

+5

-0

t/60-tied.t less more

9	9	}
10	10	}
11	11
	12	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	13
12	14	tie my %hv, 'IPC::Shareable', {destroy => 1};
13	15
14	16	$hv{a} = 'foo';

19	21
20	22	is %hv, '', "data is removed after tied(\$data)->clean_up()";
21	23
	24	IPC::Shareable::_end;
	25	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	26
22	27	done_testing();

+5

-0

t/61-seg_sem.t less more

10	10	plan skip_all => "Not on a legit CI platform...";
11	11	}
12	12	}
	13
	14	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
13	15
14	16	my $k = tie my $sv, 'IPC::Shareable', 'test', { create => 1, destroy => 1 };
15	17

49	51
50	52	is $knot_sem->id, $tied_sem->id, "knot and tied sem() hashes have the same id";
51	53
	54	IPC::Shareable::_end;
	55	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	56
52	57	done_testing();
53	58

+5

-0

t/63-nested_segs_tidy.t less more

10	10	plan skip_all => "Not on a legit CI platform...";
11	11	}
12	12	}
	13
	14	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
13	15
14	16	# array
15	17	{

96	98	IPC::Shareable->clean_up_all;
97	99	}
98	100
	101	IPC::Shareable::_end;
	102	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	103
99	104	done_testing;
100	105
101	106	sub seg_count {

+5

-0

t/64-nested_segs_untidy.t less more

10	10	plan skip_all => "Not on a legit CI platform...";
11	11	}
12	12	}
	13
	14	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
13	15
14	16	# array
15	17	{

96	98	IPC::Shareable->clean_up_all;
97	99	}
98	100
	101	IPC::Shareable::_end;
	102	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	103
99	104	done_testing;
100	105
101	106	sub seg_count {

+5

-0

t/65-seg_size.t less more

12	12	plan skip_all => "This test script can't be run on a perl < 64-bit";
13	13	}
14	14	}
	15
	16	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
15	17
16	18	use constant BYTES => 2000000; # ~2MB
17	19

104	106
105	107	$k->clean_up_all;
106	108
	109	IPC::Shareable::_end;
	110	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	111
107	112	done_testing();

+5

-0

t/66-size_exceeded.t less more

8	8	plan skip_all => "Not on a legit CI platform...";
9	9	}
10	10	}
	11
	12	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
11	13
12	14	my $k = tie my $sv, 'IPC::Shareable', {
13	15	create => 1,

25	27
26	28	(tied $sv)->clean_up_all;
27	29
	30	IPC::Shareable::_end;
	31	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	32
28	33	done_testing();

+5

-0

t/67-exhaust_shm_slots.t less more

8	8	plan skip_all => "Not on a legit CI platform...";
9	9	}
10	10	}
	11
	12	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
11	13
12	14	my $mod = 'IPC::Shareable';
13	15

33	35
34	36	IPC::Shareable->clean_up_all;
35	37
	38	IPC::Shareable::_end;
	39	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	40
36	41	done_testing();

+0

-31

~~t/71-unspawn.t~~ less more

0		use warnings;
1		use strict;
2
3		use Config;
4		use IPC::Shareable;
5		use Test::More;
6
7		BEGIN {
8		if (! $ENV{CI_TESTING}) {
9		plan skip_all => "Not on a legit CI platform...";
10		}
11		if ($Config{nvsize} != 8) {
12		plan skip_all => "Storable not compatible with long doubles";
13		}
14		}
15
16		system "$^X t/_spawn";
17
18		tie my %h, 'IPC::Shareable', {
19		key => 'aaaa',
20		# destroy => 1,
21		mode => 0666,
22		};
23
24		is $h{t70}->[1], 5, "hash element ok";
25
26		IPC::Shareable->unspawn('aaaa');
27
28		is %h, 1, "hash still exists with unspawn and no destroy";
29
30		done_testing();

+0

-30

~~t/72-unspawn_destroy.t~~ less more

0		use warnings;
1		use strict;
2
3		use Config;
4		use Data::Dumper;
5		use IPC::Shareable;
6		use Test::More;
7
8		BEGIN {
9		if (! $ENV{CI_TESTING}) {
10		plan skip_all => "Not on a legit CI platform...";
11		}
12		if ($Config{nvsize} != 8) {
13		plan skip_all => "Storable not compatible with long doubles";
14		}
15		}
16
17		tie my %h, 'IPC::Shareable', {
18		key => 'aaaa',
19		destroy => 1,
20		mode => 0666,
21		};
22
23		is $h{t70}->[1], 5, "hash element ok";
24
25		IPC::Shareable->unspawn('aaaa', 1);
26
27		is %h, '', "hash deleted after calling unspawn() with destroy => 1";
28
29		done_testing();

+6

-1

t/75-graceful.t less more

8	8	plan skip_all => "Not on a legit CI platform...";
9	9	}
10	10	}
	11
	12	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
11	13
12	14	# non-graceful
13	15	{

64	66	is
65	67	$@,
66	68	'',
67		"with 'graceful', we silently exit if two attemps made on same exclusive seg";
	69	"with 'graceful', we silently exit if two attempts made on same exclusive seg";
	70
	71	IPC::Shareable::_end;
	72	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
68	73
69	74	done_testing;
70	75	};

+6

-0

t/76-singleton.t less more

8	8	plan skip_all => "Not on a legit CI platform...";
9	9	}
10	10	}
	11
	12	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
11	13
12	14	# bad param
13	15

36	38	END {
37	39	is $proc, -1, "singleton() on second call doesn't return anything ok";
38	40	is $warning, undef, "singleton outputs no warnings by default";
	41
	42	IPC::Shareable::_end;
	43	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	44
39	45	done_testing;
40	46	};

+5

-0

t/77-singleton_warn.t less more

8	8	plan skip_all => "Not on a legit CI platform...";
9	9	}
10	10	}
	11
	12	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
11	13
12	14	# singleton no exit notice
13	15	my ($proc, $warning);

33	35	qr/exited due to exclusive shared memory collision/,
34	36	"singleton() warns if warn is enabled";
35	37
	38	IPC::Shareable::_end;
	39	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	40
36	41	done_testing;
37	42	};

+5

-0

t/80-exceptions.t less more

11	11	plan skip_all => "Not on a legit CI platform...";
12	12	}
13	13	}
	14
	15	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
14	16
15	17	{
16	18	# exclusive duplicate

40	42
41	43	}
42	44
	45	IPC::Shareable::_end;
	46	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	47
43	48	done_testing();

+40

-31

t/81-fork_dup_rand_keys.t less more

0	0	use warnings;
1	1	use strict;
2	2
3		use Data::Dumper;
4	3	use IPC::Shareable;
5	4	use Test::More;
	5
	6	my $segs_before;
6	7
7	8	BEGIN {
8	9	if (! $ENV{CI_TESTING}) {
9	10	plan skip_all => "Not on a legit CI platform...";
10	11	}
11	12
12		my $async_loaded = eval {
13		require Async::Event::Interval;
14		1;
	13	if (! $ENV{RELEASE_TESTING}) {
	14	plan skip_all => "Developer only test...";
	15	}
	16
	17	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	18	$segs_before = IPC::Shareable::ipcs();
	19	}
	20
	21	use Async::Event::Interval;
	22
	23	{
	24	tie my %shared_data, 'IPC::Shareable', {
	25	key => 'fork rand dup keys',
	26	create => 1,
	27	destroy => 1
15	28	};
16	29
17		if (! $async_loaded) {
18		plan skip_all => "Async::Event::Interval not loaded...";
19		}
	30	my $event_one = Async::Event::Interval->new(0, sub {$shared_data{$$}{called}++});
	31	my $event_two = Async::Event::Interval->new(0, sub {$shared_data{$$}{called}++});
	32
	33	$event_one->start;
	34	$event_two->start;
	35
	36	sleep 1;
	37
	38	$event_one->stop;
	39	$event_two->stop;
	40
	41	my $one_pid = $event_one->pid;
	42	my $two_pid = $event_two->pid;
	43
	44	is exists $shared_data{$one_pid}{called}, 1, "Event one got a rand shm key ok";
	45	is exists $shared_data{$two_pid}{called}, 1, "Adding srand() ensures _shm_key_rand() gives out rand key in fork()";
	46
	47	IPC::Shareable::clean_up_all;
20	48	}
21	49
22		tie my %shared_data, 'IPC::Shareable', {
23		key => '123456789',
24		create => 1,
25		destroy => 1
26		};
	50	Async::Event::Interval::_end;
	51	IPC::Shareable::_end;
27	52
28		$shared_data{$$}{called}++;
	53	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	54	my $segs_after = IPC::Shareable::ipcs();
29	55
30		my $event_one = Async::Event::Interval->new(0, sub {$shared_data{$$}{called}++});
31		my $event_two = Async::Event::Interval->new(0, sub {$shared_data{$$}{called}++});
32
33		$event_one->start;
34		$event_two->start;
35
36		sleep 1;
37
38		$event_one->stop;
39		$event_two->stop;
40
41		my $one_pid = $event_one->pid;
42		my $two_pid = $event_two->pid;
43
44		is exists $shared_data{$one_pid}{called}, 1, "Event one got a rand shm key ok";
45		is exists $shared_data{$two_pid}{called}, 1, "Adding srand() ensures _shm_key_rand() gives out rand key in fork()";
46
47		(tied %shared_data)->remove;
	56	is $segs_after, $segs_before, "All segs, even those created in separate procs, cleaned up ok";
48	57
49	58	done_testing();

+5

-0

t/82-sig_child_ignore.t less more

9	9	}
10	10	}
11	11
	12	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	13
12	14	my @command = ('date');
13	15	my $rc = system( @command );
14	16
15	17	is $rc, 0, "system() returns success ok after moving CHLD handler";
16	18
	19	IPC::Shareable::_end;
	20	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	21
17	22	done_testing();

+5

-0

t/83-clean_protected.t less more

9	9	plan skip_all => "Not on a legit CI platform...";
10	10	}
11	11	}
	12
	13	warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
12	14
13	15	my $protect_lock = 292;
14	16

85	87	$segs = keys %{ IPC::Shareable::global_register() };
86	88	is $segs, 0, "After clean_up_protected(), global register has 0 segments ok";
87	89
	90	IPC::Shareable::_end;
	91	warn "Segs After: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
	92
88	93	done_testing();

+0

-42

~~t/85-spawn_object_contains_data.t~~ less more

0		use warnings;
1		use strict;
2
3		use lib 't/';
4		use Test::More;
5
6		BEGIN {
7		if (! $ENV{CI_TESTING}) {
8		plan skip_all => "Not on a legit CI platform...";
9		}
10		if (!$ENV{IPC_SPAWN_TEST}) {
11		plan skip_all => "IPC_SPAWN_TEST env var not set";
12		}
13		}
14
15		use SpawnTest;
16		use IPC::Shareable;
17
18		if (! $ENV{CI_TESTING}) {
19		plan skip_all => "Not on a legit CI platform...";
20		}
21		if (! $ENV{IPC_SPAWN_TEST}) {
22		plan skip_all => "IPC_SPAWN_TEST env var not set";
23		}
24
25		my $obj = SpawnTest->new;
26
27		$obj->add(27);
28		is $obj->{data}{add}, 27, "add() adds 27 ok";
29		$obj->add(27);
30		is $obj->{data}{add}, 54, "add() with 27 again is 54 ok";
31
32
33		for (0..10){
34		$obj->push($_);
35		is $obj->{data}{array}[$_], $_, "push() with $_ is $_ ok";
36		}
37
38		$obj->push(99);
39		is $obj->{data}{array}[11], 99, "push() pushes 99 into last elem ok";
40
41		done_testing();

+0

-36

~~t/86-unspawn_object_contains_data.t~~ less more

0		use warnings;
1		use strict;
2
3		use lib 't/';
4
5		use Test::More;
6
7		BEGIN {
8		if (! $ENV{CI_TESTING}) {
9		plan skip_all => "Not on a legit CI platform...";
10		}
11		if (!$ENV{IPC_SPAWN_TEST}) {
12		plan skip_all => "IPC_SPAWN_TEST env var not set";
13		}
14		}
15
16		use SpawnTest;
17		use IPC::Shareable;
18
19		my $obj = SpawnTest->new;
20
21		is $obj->{data}{add}, 54, "data retained 54 in add()";
22		$obj->add(27);
23		is $obj->{data}{add}, 81, "add() with 27 again works ok (81)";
24
25
26		for (0..10){
27		is $obj->{data}{array}[$_], $_, "push() with $_ is $_ ok";
28		}
29
30		$obj->push(100);
31		is $obj->{data}{array}[12], 100, "push() pushes 100 into new last elem ok";
32
33		$obj->clean;
34
35		done_testing();

+28

-0

t/99-end.t less more

	0	use 5.006;
	1	use strict;
	2	use warnings;
	3
	4	use IPC::Shareable;
	5	use Test::More;
	6
	7	BEGIN {
	8	use_ok( 'IPC::Shareable' ) \|\| print "Bail out!\n";
	9	}
	10
	11	if (! $ENV{CI_TESTING}) {
	12	done_testing();
	13	exit;
	14	}
	15
	16	tie my %store, 'IPC::Shareable', {key => 'async_tests', destroy => 1};
	17
	18	my $start_segs = $store{segs};
	19	IPC::Shareable::clean_up_all;
	20
	21	my $segs = IPC::Shareable::ipcs();
	22
	23	is $segs, $start_segs, "All test segments cleaned up after test run";
	24
	25	print "Started with $start_segs, ending with $segs\n";
	26
	27	done_testing();⏎

+0

-35

~~t/SpawnTest.pm~~ less more

0		package SpawnTest;
1
2		use warnings;
3		use strict;
4
5		use IPC::Shareable;
6
7		system "perl t/_spawn_class";
8
9		tie my %h, 'IPC::Shareable', {
10		key => 'bbbb',
11		};
12
13		sub new {
14		my ($class) = @_;
15		return bless { data => \%h }, $class;
16		}
17		sub add {
18		my ($self, $num) = @_;
19		die "need a num param\n" if ! defined $num;
20		$self->data->{add} += $num;
21		}
22		sub push {
23		my ($self, $value) = @_;
24		die "need a value param\n" if ! defined $value;
25		push @{ $self->data->{array} }, $value;
26		}
27		sub data {
28		return $_[0]->{data};
29		}
30
31		sub clean {
32		IPC::Shareable->unspawn('bbbb', 1);
33		}
34		1;⏎

+0

-16

~~t/_spawn~~ less more

0		use warnings;
1		use strict;
2
3		use IPC::Shareable;
4
5		IPC::Shareable->spawn(
6		key => 'aaaa'
7		);
8
9		sleep 1;
10
11		tie my %h, 'IPC::Shareable', {
12		key => 'aaaa',
13		};
14
15		$h{t70}->[1] = 5;

+0

-13

~~t/_spawn_class~~ less more

0		use warnings;
1		use strict;
2
3		use IPC::Shareable;
4
5		IPC::Shareable->spawn(
6		key => 'bbbb',
7
8		create => 1
9		);
10
11		sleep 1;
12		exit 0;