This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
The SysV IPC test must use the native integers
[perl5.git] / t / lib / ipc_sysv.t
CommitLineData
3784f770
JH
1#!./perl
2
3BEGIN {
4 chdir 't' if -d 't';
5
93430cb4 6 unshift @INC, '../lib';
3784f770
JH
7
8 require Config; import Config;
9
45c0de28
GS
10 my $reason;
11
12 if ($Config{'d_sem'} ne 'define') {
13 $reason = '$Config{d_sem} undefined';
14 } elsif ($Config{'d_msg'} ne 'define') {
15 $reason = '$Config{d_msg} undefined';
16 }
17 if ($reason) {
18 print "1..0 # Skip: $reason\n";
19 exit 0;
3784f770
JH
20 }
21}
22
23# These constants are common to all tests.
24# Later the sem* tests will import more for themselves.
25
26use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID
ea492b46 27 S_IRWXU S_IRWXG S_IRWXO S_IWGRP S_IROTH S_IWOTH);
3784f770
JH
28use strict;
29
30print "1..16\n";
31
32my $msg;
33my $sem;
34
35$SIG{__DIE__} = 'cleanup'; # will cleanup $msg and $sem if needed
36
6087ac44
JH
37# FreeBSD is known to throw this if there's no SysV IPC in the kernel.
38$SIG{SYS} = sub {
39 print STDERR <<EOM;
40SIGSYS caught.
41It may be that your kernel does not have SysV IPC configured.
42
43EOM
44 if ($^O eq 'freebsd') {
45 print STDERR <<EOM;
46You must have following options in your kernel:
47
48options SYSVSHM
49options SYSVSEM
50options SYSVMSG
51
52See config(8).
53EOM
54 }
55 exit(1);
56};
57
092bebab
JH
58my $perm;
59
60$perm = S_IRWXU | S_IRWXG | S_IRWXO | S_IWGRP | S_IROTH | S_IWOTH
61 if $^O eq 'vmesa';
62
63$perm = S_IRWXU | S_IRWXG | S_IRWXO unless defined $perm;
64
3784f770
JH
65if ($Config{'d_msgget'} eq 'define' &&
66 $Config{'d_msgctl'} eq 'define' &&
67 $Config{'d_msgsnd'} eq 'define' &&
68 $Config{'d_msgrcv'} eq 'define') {
092bebab
JH
69
70 $msg = msgget(IPC_PRIVATE, $perm);
3784f770
JH
71 # Very first time called after machine is booted value may be 0
72 die "msgget failed: $!\n" unless defined($msg) && $msg >= 0;
73
74 print "ok 1\n";
75
76 #Putting a message on the queue
77 my $msgtype = 1;
78 my $msgtext = "hello";
79
8f753cb5
JH
80 my $test2bad;
81 my $test5bad;
82 my $test6bad;
83
e4038a1f 84 unless (msgsnd($msg,pack("L! a*",$msgtype,$msgtext),IPC_NOWAIT)) {
8f753cb5 85 print "not ";
19e194ad 86 $test2bad = 1;
8f753cb5 87 }
3784f770 88 print "ok 2\n";
8f753cb5
JH
89 if ($test2bad) {
90 print <<EOM;
91#
92# The failure of the subtest #2 may indicate that the message queue
93# resource limits either of the system or of the testing account
94# have been reached. Error message "Operating would block" is
95# usually indicative of this situation. The error message was now:
96# "$!"
97#
98# You can check the message queues with the 'ipcs' command and
99# you can remove unneeded queues with the 'ipcrm -q id' command.
100# You may also consider configuring your system or account
101# to have more message queue resources.
102#
103# Because of the subtest #2 failing also the substests #5 and #6 will
104# very probably also fail.
105#
106EOM
107 }
3784f770
JH
108
109 my $data;
110 msgctl($msg,IPC_STAT,$data) or print "not ";
111 print "ok 3\n";
112
113 print "not " unless length($data);
114 print "ok 4\n";
115
116 my $msgbuf;
8f753cb5
JH
117 unless (msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT)) {
118 print "not ";
119 $test5bad = 1;
120 }
3784f770 121 print "ok 5\n";
8f753cb5
JH
122 if ($test5bad && $test2bad) {
123 print <<EOM;
124#
125# This failure was to be expected because the subtest #2 failed.
126#
127EOM
128 }
3784f770 129
19e194ad 130 my($rmsgtype,$rmsgtext);
e4038a1f 131 ($rmsgtype,$rmsgtext) = unpack("L! a*",$msgbuf)
8f753cb5
JH
132 unless($rmsgtype == $msgtype && $rmsgtext eq $msgtext) {
133 print "not ";
134 $test6bad = 1;
135 }
3784f770 136 print "ok 6\n";
8f753cb5
JH
137 if ($test6bad && $test2bad) {
138 print <<EOM;
139#
140# This failure was to be expected because the subtest #2 failed.
141#
142EOM
143 }
3784f770
JH
144} else {
145 for (1..6) {
146 print "ok $_\n"; # fake it
147 }
148}
149
150if($Config{'d_semget'} eq 'define' &&
151 $Config{'d_semctl'} eq 'define') {
152
ae1e0c5f
JH
153 if ($Config{'d_semctl_semid_ds'} eq 'define' ||
154 $Config{'d_semctl_semun'} eq 'define') {
3784f770 155
ae1e0c5f 156 use IPC::SysV qw(IPC_CREAT GETALL SETALL);
3784f770 157
ae1e0c5f
JH
158 $sem = semget(IPC_PRIVATE, 10, $perm | IPC_CREAT);
159 # Very first time called after machine is booted value may be 0
160 die "semget: $!\n" unless defined($sem) && $sem >= 0;
3784f770 161
ae1e0c5f 162 print "ok 7\n";
3784f770 163
ae1e0c5f
JH
164 my $data;
165 semctl($sem,0,IPC_STAT,$data) or print "not ";
166 print "ok 8\n";
167
168 print "not " unless length($data);
169 print "ok 9\n";
3784f770 170
ae1e0c5f 171 my $nsem = 10;
3784f770 172
ae1e0c5f
JH
173 semctl($sem,0,SETALL,pack("s!*",(0) x $nsem)) or print "not ";
174 print "ok 10\n";
3784f770 175
ae1e0c5f
JH
176 $data = "";
177 semctl($sem,0,GETALL,$data) or print "not ";
178 print "ok 11\n";
3784f770 179
ae1e0c5f
JH
180 print "not " unless length($data) == length(pack("s!*",(0) x $nsem));
181 print "ok 12\n";
3784f770 182
ae1e0c5f 183 my @data = unpack("s!*",$data);
3784f770 184
ae1e0c5f 185 my $adata = "0" x $nsem;
3784f770 186
ae1e0c5f
JH
187 print "not " unless @data == $nsem and join("",@data) eq $adata;
188 print "ok 13\n";
3784f770 189
ae1e0c5f 190 my $poke = 2;
3784f770 191
ae1e0c5f
JH
192 $data[$poke] = 1;
193 semctl($sem,0,SETALL,pack("s!*",@data)) or print "not ";
194 print "ok 14\n";
3784f770 195
ae1e0c5f
JH
196 $data = "";
197 semctl($sem,0,GETALL,$data) or print "not ";
198 print "ok 15\n";
3784f770 199
ae1e0c5f 200 @data = unpack("s!*",$data);
3784f770 201
ae1e0c5f 202 my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1);
3784f770 203
ae1e0c5f
JH
204 print "not " unless join("",@data) eq $bdata;
205 print "ok 16\n";
206 } else {
207 for (7..16) {
208 print "ok $_ # skipped, no semctl possible\n";
209 }
210 }
3784f770
JH
211} else {
212 for (7..16) {
213 print "ok $_\n"; # fake it
214 }
215}
216
217sub cleanup {
218 msgctl($msg,IPC_RMID,0) if defined $msg;
219 semctl($sem,0,IPC_RMID,undef) if defined $sem;
220}
221
222cleanup;