This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update IPC-SysV to CPAN version 2.04
[perl5.git] / cpan / IPC-SysV / t / sem.t
1 ################################################################################
2 #
3 #  Version 2.x, Copyright (C) 2007-2013, Marcus Holland-Moritz <mhx@cpan.org>.
4 #  Version 1.x, Copyright (C) 1999, Graham Barr <gbarr@pobox.com>.
5 #
6 #  This program is free software; you can redistribute it and/or
7 #  modify it under the same terms as Perl itself.
8 #
9 ################################################################################
10
11 BEGIN {
12   if ($ENV{'PERL_CORE'}) {
13     chdir 't' if -d 't';
14     @INC = '../lib' if -d '../lib' && -d '../ext';
15   }
16
17   require Test::More; import Test::More;
18   require Config; import Config;
19
20   if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) {
21     plan(skip_all => 'IPC::SysV was not built');
22   }
23 }
24
25 if ($Config{'d_sem'} ne 'define') {
26   plan(skip_all => '$Config{d_sem} undefined');
27 }
28 elsif ($Config{'d_msg'} ne 'define') {
29   plan(skip_all => '$Config{d_msg} undefined');
30 }
31
32 use IPC::SysV qw(
33         SETALL
34         IPC_PRIVATE
35         IPC_CREAT
36         IPC_RMID
37         IPC_NOWAIT
38         IPC_STAT
39         S_IRWXU
40         S_IRWXG
41         S_IRWXO
42 );
43 use IPC::Semaphore;
44
45 # FreeBSD's default limit seems to be 9
46 my $nsem = 5;
47 my $sem = sub {
48   my $code = shift;
49   if (exists $SIG{SYS}) {
50     local $SIG{SYS} = sub { plan(skip_all => "SIGSYS caught") };
51     return $code->();
52   }
53   return $code->();
54 }->(sub { IPC::Semaphore->new(IPC_PRIVATE, $nsem, S_IRWXU | S_IRWXG | S_IRWXO | IPC_CREAT) });
55
56 unless (defined $sem) {
57   my $info = "IPC::Semaphore->new failed: $!";
58   if ($! == &IPC::SysV::ENOSPC || $! == &IPC::SysV::ENOSYS ||
59       $! == &IPC::SysV::ENOMEM || $! == &IPC::SysV::EACCES) {
60     plan(skip_all => $info);
61   }
62   else {
63     die $info;
64   }
65 }
66
67 plan(tests => 11);
68
69 pass('acquired a semaphore');
70
71 ok(my $st = $sem->stat,'stat it');
72
73 ok($sem->setall((0) x $nsem), 'set all');
74
75 my @sem = $sem->getall;
76 cmp_ok(join("", @sem), 'eq', "00000", 'get all');
77
78 $sem[2] = 1;
79 ok($sem->setall(@sem), 'set after change');
80
81 @sem = $sem->getall;
82 cmp_ok(join("", @sem), 'eq', "00100", 'get again');
83
84 my $ncnt = $sem->getncnt(0);
85 ok(!$sem->getncnt(0), 'procs waiting now');
86 ok(defined($ncnt), 'prev procs waiting');
87
88 ok($sem->op(2, -1, IPC_NOWAIT), 'op nowait');
89
90 ok(!$sem->getncnt(0), 'no procs waiting');
91
92 END {
93   ok($sem->remove, 'remove semaphore') if defined $sem;
94 }