This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Forgot few S_I* imports.
[perl5.git] / t / lib / ipc_sysv.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5
6     @INC = '../lib';
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
20 use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID
21                  S_IRWXU S_IRWXG S_IRWXO S_IWGRP S_IROTH S_IWOTH);
22 use strict;
23
24 print "1..16\n";
25
26 my $msg;
27 my $sem;
28
29 $SIG{__DIE__} = 'cleanup'; # will cleanup $msg and $sem if needed
30
31 # FreeBSD is known to throw this if there's no SysV IPC in the kernel.
32 $SIG{SYS} = sub {
33     print STDERR <<EOM;
34 SIGSYS caught.
35 It may be that your kernel does not have SysV IPC configured.
36
37 EOM
38     if ($^O eq 'freebsd') {
39         print STDERR <<EOM;
40 You must have following options in your kernel:
41
42 options         SYSVSHM
43 options         SYSVSEM
44 options         SYSVMSG
45
46 See config(8).
47 EOM
48     }
49     exit(1);
50 };
51
52 my $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
59 if ($Config{'d_msgget'} eq 'define' &&
60     $Config{'d_msgctl'} eq 'define' &&
61     $Config{'d_msgsnd'} eq 'define' &&
62     $Config{'d_msgrcv'} eq 'define') {
63
64     $msg = msgget(IPC_PRIVATE, $perm);
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
98 if($Config{'d_semget'} eq 'define' &&
99    $Config{'d_semctl'} eq 'define') {
100
101     use IPC::SysV qw(IPC_CREAT GETALL SETALL);
102
103     $sem = semget(IPC_PRIVATE, 10, $perm | IPC_CREAT);
104     # Very first time called after machine is booted value may be 0 
105     die "semget: $!\n" unless defined($sem) && $sem >= 0;
106
107     print "ok 7\n";
108
109     my $data;
110     semctl($sem,0,IPC_STAT,$data) or print "not ";
111     print "ok 8\n";
112
113     print "not " unless length($data);
114     print "ok 9\n";
115
116     my $template;
117
118     # Find the pack/unpack template capable of handling native C shorts.
119
120     if      ($Config{shortsize} == 2) {
121         $template = "s";
122     } elsif ($Config{shortsize} == 4) {
123         $template = "l";
124     } elsif ($Config{shortsize} == 8) {
125         # Try quad last because not supported everywhere.
126         foreach my $t (qw(i q)) {
127             # We could trap the unsupported quad template with eval
128             # but if we get this far we should have quad support anyway.
129             if (length(pack($t, 0)) == 8) {
130                 $template = $t;
131                 last;
132             }
133         }
134     }
135
136     die "$0: cannot pack native shorts\n" unless defined $template;
137
138     $template .= "*";
139
140     my $nsem = 10;
141
142     semctl($sem,0,SETALL,pack($template,(0) x $nsem)) or print "not ";
143     print "ok 10\n";
144
145     $data = "";
146     semctl($sem,0,GETALL,$data) or print "not ";
147     print "ok 11\n";
148
149     print "not " unless length($data) == length(pack($template,(0) x $nsem));
150     print "ok 12\n";
151
152     my @data = unpack($template,$data);
153
154     my $adata = "0" x $nsem;
155
156     print "not " unless @data == $nsem and join("",@data) eq $adata;
157     print "ok 13\n";
158
159     my $poke = 2;
160
161     $data[$poke] = 1;
162     semctl($sem,0,SETALL,pack($template,@data)) or print "not ";
163     print "ok 14\n";
164     
165     $data = "";
166     semctl($sem,0,GETALL,$data) or print "not ";
167     print "ok 15\n";
168
169     @data = unpack($template,$data);
170
171     my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1);
172
173     print "not " unless join("",@data) eq $bdata;
174     print "ok 16\n";
175 } else {
176     for (7..16) {
177         print "ok $_\n"; # fake it
178     }
179 }
180
181 sub cleanup {
182     msgctl($msg,IPC_RMID,0)       if defined $msg;
183     semctl($sem,0,IPC_RMID,undef) if defined $sem;
184 }
185
186 cleanup;