This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
move op/ipc{msg,sem}.t into lib/ipc_sysv.t
[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);
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 if ($Config{'d_msgget'} eq 'define' &&
32     $Config{'d_msgctl'} eq 'define' &&
33     $Config{'d_msgsnd'} eq 'define' &&
34     $Config{'d_msgrcv'} eq 'define') {
35     $msg = msgget(IPC_PRIVATE, S_IRWXU | S_IRWXG | S_IRWXO);
36     # Very first time called after machine is booted value may be 0 
37     die "msgget failed: $!\n" unless defined($msg) && $msg >= 0;
38
39     print "ok 1\n";
40
41     #Putting a message on the queue
42     my $msgtype = 1;
43     my $msgtext = "hello";
44
45     msgsnd($msg,pack("L a*",$msgtype,$msgtext),0) or print "not ";
46     print "ok 2\n";
47
48     my $data;
49     msgctl($msg,IPC_STAT,$data) or print "not ";
50     print "ok 3\n";
51
52     print "not " unless length($data);
53     print "ok 4\n";
54
55     my $msgbuf;
56     msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT) or print "not ";
57     print "ok 5\n";
58
59     my($rmsgtype,$rmsgtext) = unpack("L a*",$msgbuf);
60
61     print "not " unless($rmsgtype == $msgtype && $rmsgtext eq $msgtext);
62     print "ok 6\n";
63 } else {
64     for (1..6) {
65         print "ok $_\n"; # fake it
66     }
67 }
68
69 if($Config{'d_semget'} eq 'define' &&
70    $Config{'d_semctl'} eq 'define') {
71
72     use IPC::SysV qw(IPC_CREAT GETALL SETALL);
73
74     $sem = semget(IPC_PRIVATE, 10, S_IRWXU | S_IRWXG | S_IRWXO | IPC_CREAT);
75     # Very first time called after machine is booted value may be 0 
76     die "semget: $!\n" unless defined($sem) && $sem >= 0;
77
78     print "ok 7\n";
79
80     my $data;
81     semctl($sem,0,IPC_STAT,$data) or print "not ";
82     print "ok 8\n";
83
84     print "not " unless length($data);
85     print "ok 9\n";
86
87     my $template;
88
89     # Find the pack/unpack template capable of handling native C shorts.
90
91     if      ($Config{shortsize} == 2) {
92         $template = "s";
93     } elsif ($Config{shortsize} == 4) {
94         $template = "l";
95     } elsif ($Config{shortsize} == 8) {
96         # Try quad last because not supported everywhere.
97         foreach my $t (qw(i q)) {
98             # We could trap the unsupported quad template with eval
99             # but if we get this far we should have quad support anyway.
100             if (length(pack($t, 0)) == 8) {
101                 $template = $t;
102                 last;
103             }
104         }
105     }
106
107     die "$0: cannot pack native shorts\n" unless defined $template;
108
109     $template .= "*";
110
111     my $nsem = 10;
112
113     semctl($sem,0,SETALL,pack($template,(0) x $nsem)) or print "not ";
114     print "ok 10\n";
115
116     $data = "";
117     semctl($sem,0,GETALL,$data) or print "not ";
118     print "ok 11\n";
119
120     print "not " unless length($data) == length(pack($template,(0) x $nsem));
121     print "ok 12\n";
122
123     my @data = unpack($template,$data);
124
125     my $adata = "0" x $nsem;
126
127     print "not " unless @data == $nsem and join("",@data) eq $adata;
128     print "ok 13\n";
129
130     my $poke = 2;
131
132     $data[$poke] = 1;
133     semctl($sem,0,SETALL,pack($template,@data)) or print "not ";
134     print "ok 14\n";
135     
136     $data = "";
137     semctl($sem,0,GETALL,$data) or print "not ";
138     print "ok 15\n";
139
140     @data = unpack($template,$data);
141
142     my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1);
143
144     print "not " unless join("",@data) eq $bdata;
145     print "ok 16\n";
146 } else {
147     for (7..16) {
148         print "ok $_\n"; # fake it
149     }
150 }
151
152 sub cleanup {
153     msgctl($msg,IPC_RMID,0)       if defined $msg;
154     semctl($sem,0,IPC_RMID,undef) if defined $sem;
155 }
156
157 cleanup;