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