This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
If both ways to call semctl are broken, skip the tests.
[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
10 unless ($Config{'d_msg'} eq 'define' &&
11 $Config{'d_sem'} eq 'define') {
12 print "1..0\n";
13 exit;
14 }
15}
16
17# These constants are common to all tests.
18# Later the sem* tests will import more for themselves.
19
20use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID
ea492b46 21 S_IRWXU S_IRWXG S_IRWXO S_IWGRP S_IROTH S_IWOTH);
3784f770
JH
22use strict;
23
24print "1..16\n";
25
26my $msg;
27my $sem;
28
29$SIG{__DIE__} = 'cleanup'; # will cleanup $msg and $sem if needed
30
6087ac44
JH
31# FreeBSD is known to throw this if there's no SysV IPC in the kernel.
32$SIG{SYS} = sub {
33 print STDERR <<EOM;
34SIGSYS caught.
35It may be that your kernel does not have SysV IPC configured.
36
37EOM
38 if ($^O eq 'freebsd') {
39 print STDERR <<EOM;
40You must have following options in your kernel:
41
42options SYSVSHM
43options SYSVSEM
44options SYSVMSG
45
46See config(8).
47EOM
48 }
49 exit(1);
50};
51
092bebab
JH
52my $perm;
53
54$perm = S_IRWXU | S_IRWXG | S_IRWXO | S_IWGRP | S_IROTH | S_IWOTH
55 if $^O eq 'vmesa';
56
57$perm = S_IRWXU | S_IRWXG | S_IRWXO unless defined $perm;
58
3784f770
JH
59if ($Config{'d_msgget'} eq 'define' &&
60 $Config{'d_msgctl'} eq 'define' &&
61 $Config{'d_msgsnd'} eq 'define' &&
62 $Config{'d_msgrcv'} eq 'define') {
092bebab
JH
63
64 $msg = msgget(IPC_PRIVATE, $perm);
3784f770
JH
65 # Very first time called after machine is booted value may be 0
66 die "msgget failed: $!\n" unless defined($msg) && $msg >= 0;
67
68 print "ok 1\n";
69
70 #Putting a message on the queue
71 my $msgtype = 1;
72 my $msgtext = "hello";
73
74 msgsnd($msg,pack("L a*",$msgtype,$msgtext),0) or print "not ";
75 print "ok 2\n";
76
77 my $data;
78 msgctl($msg,IPC_STAT,$data) or print "not ";
79 print "ok 3\n";
80
81 print "not " unless length($data);
82 print "ok 4\n";
83
84 my $msgbuf;
85 msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT) or print "not ";
86 print "ok 5\n";
87
88 my($rmsgtype,$rmsgtext) = unpack("L a*",$msgbuf);
89
90 print "not " unless($rmsgtype == $msgtype && $rmsgtext eq $msgtext);
91 print "ok 6\n";
92} else {
93 for (1..6) {
94 print "ok $_\n"; # fake it
95 }
96}
97
98if($Config{'d_semget'} eq 'define' &&
99 $Config{'d_semctl'} eq 'define') {
100
ae1e0c5f
JH
101 if ($Config{'d_semctl_semid_ds'} eq 'define' ||
102 $Config{'d_semctl_semun'} eq 'define') {
3784f770 103
ae1e0c5f 104 use IPC::SysV qw(IPC_CREAT GETALL SETALL);
3784f770 105
ae1e0c5f
JH
106 $sem = semget(IPC_PRIVATE, 10, $perm | IPC_CREAT);
107 # Very first time called after machine is booted value may be 0
108 die "semget: $!\n" unless defined($sem) && $sem >= 0;
3784f770 109
ae1e0c5f 110 print "ok 7\n";
3784f770 111
ae1e0c5f
JH
112 my $data;
113 semctl($sem,0,IPC_STAT,$data) or print "not ";
114 print "ok 8\n";
115
116 print "not " unless length($data);
117 print "ok 9\n";
3784f770 118
ae1e0c5f 119 my $nsem = 10;
3784f770 120
ae1e0c5f
JH
121 semctl($sem,0,SETALL,pack("s!*",(0) x $nsem)) or print "not ";
122 print "ok 10\n";
3784f770 123
ae1e0c5f
JH
124 $data = "";
125 semctl($sem,0,GETALL,$data) or print "not ";
126 print "ok 11\n";
3784f770 127
ae1e0c5f
JH
128 print "not " unless length($data) == length(pack("s!*",(0) x $nsem));
129 print "ok 12\n";
3784f770 130
ae1e0c5f 131 my @data = unpack("s!*",$data);
3784f770 132
ae1e0c5f 133 my $adata = "0" x $nsem;
3784f770 134
ae1e0c5f
JH
135 print "not " unless @data == $nsem and join("",@data) eq $adata;
136 print "ok 13\n";
3784f770 137
ae1e0c5f 138 my $poke = 2;
3784f770 139
ae1e0c5f
JH
140 $data[$poke] = 1;
141 semctl($sem,0,SETALL,pack("s!*",@data)) or print "not ";
142 print "ok 14\n";
3784f770 143
ae1e0c5f
JH
144 $data = "";
145 semctl($sem,0,GETALL,$data) or print "not ";
146 print "ok 15\n";
3784f770 147
ae1e0c5f 148 @data = unpack("s!*",$data);
3784f770 149
ae1e0c5f 150 my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1);
3784f770 151
ae1e0c5f
JH
152 print "not " unless join("",@data) eq $bdata;
153 print "ok 16\n";
154 } else {
155 for (7..16) {
156 print "ok $_ # skipped, no semctl possible\n";
157 }
158 }
3784f770
JH
159} else {
160 for (7..16) {
161 print "ok $_\n"; # fake it
162 }
163}
164
165sub cleanup {
166 msgctl($msg,IPC_RMID,0) if defined $msg;
167 semctl($sem,0,IPC_RMID,undef) if defined $sem;
168}
169
170cleanup;