Codebase list libipc-shareable-perl / 9ddc1d8
New upstream version 1.13 gregor herrmann 1 year, 6 months ago
8 changed file(s) with 80 addition(s) and 5 deletion(s). Raw diff Collapse all Expand all
00 Revision history for Perl extension IPC::Shareable.
1
2 1.13 2022-10-11
3 - In singleton(), do a check whether class was sent in. There was a shifting
4 issue if called with IPC::Shareable::singleton() as opposed to
5 IPC::Shareable->singleton()
6 - When an exclusive collision occurs and both 'graceful' and 'warn' are set,
7 the warning thrown now includes the segment/semaphore key in use. This
8 makes it easier to clean things up with 'ipcrm'
19
210 1.12 2022-03-13
311 - Add tests in t/07-new.t to test how using tied() against a dereferenced
88 DISCLAIMER
99 'docs/Shared Memory Configuration.txt'
1010 examples/new.pl
11 ipc.pl
1112 lib/IPC/Shareable.pm
1213 lib/IPC/Shareable/SharedMem.pm
1314 Makefile.PL
4445 t/75-graceful.t
4546 t/76-singleton.t
4647 t/77-singleton_warn.t
48 t/78-singleton_class.t
4749 t/80-exceptions.t
4850 t/81-fork_dup_rand_keys.t
4951 t/82-sig_child_ignore.t
5353 "web" : "https://github.com/stevieb9/ipc-shareable"
5454 }
5555 },
56 "version" : "1.12",
56 "version" : "1.13",
5757 "x_serialization_backend" : "JSON::PP version 4.04"
5858 }
2828 resources:
2929 bugtracker: https://github.com/stevieb9/ipc-shareable/issues
3030 repository: https://github.com/stevieb9/ipc-shareable.git
31 version: '1.12'
31 version: '1.13'
3232 x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
0 use warnings;
1 use strict;
2 use feature 'say';
3
4 use Script::Singleton warn => 1;
5
6 sleep 10;
55 use Carp qw(carp croak confess);
66 use IPC::SysV qw(IPC_RMID);
77
8 our $VERSION = '1.12';
8 our $VERSION = '1.13';
99
1010 use constant DEBUGGING => ($ENV{SHM_DEBUG} or 0);
1111
2020 use String::CRC32;
2121 use Storable 0.6 qw(freeze thaw);
2222
23 our $VERSION = '1.12';
23 our $VERSION = '1.13';
2424
2525 use constant {
2626 LOCK_SH => 1,
552552 return $knot->{_sem} if defined $knot->{_sem};
553553 }
554554 sub singleton {
555
556 # If called with IPC::Shareable::singleton() as opposed to
557 # IPC::Shareable->singleton(), the class isn't sent in. Check
558 # for this and fix it if necessary
559
560 if (! defined $_[0] || $_[0] ne __PACKAGE__) {
561 unshift @_, __PACKAGE__;
562 }
563
555564 my ($class, $glue, $warn) = @_;
556565
557566 if (! defined $glue) {
716725
717726 if (! defined $exclusive) {
718727 if ($knot->attributes('warn')) {
719 warn "Process ID $$ exited due to exclusive shared memory collision\n";
728 my $key = lc(sprintf("0x%X", $knot->_shm_key));
729
730 warn "Process ID $$ exited due to exclusive shared memory collision at segment/semaphore key '$key'\n";
720731 }
721732 exit(0);
722733 }
0 use warnings;
1 use strict;
2
3 use IPC::Shareable;
4 use Test::More;
5
6 BEGIN {
7 if (! $ENV{CI_TESTING}) {
8 plan skip_all => "Not on a legit CI platform...";
9 }
10 }
11
12 warn "Segs Before: " . IPC::Shareable::ipcs() . "\n" if $ENV{PRINT_SEGS};
13
14 # bad param
15
16 my $ok = eval { IPC::Shareable::singleton(); 1 };
17 is $ok, undef, "singleton() croaks if no GLUE param sent in";
18 like $@, qr/GLUE parameter/, "...and error is sane";
19
20 # singleton no exit notice
21
22 my ($proc, $warning);
23
24 {
25 local $SIG{__WARN__} = sub {$warning = shift;};
26
27 $proc = IPC::Shareable::singleton('LOCK');
28
29 is $proc, $$, "Class param is added if called in IPC::Shareable::singleton() format";
30
31 $proc = -1;
32
33 is $proc, -1, "\$proc set to -1 ok";
34
35 $proc = IPC::Shareable::singleton('LOCK');
36 }
37
38 END {
39 is $proc, -1, "singleton() on second call doesn't return anything ok";
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
45 done_testing;
46 };