xref: /openbsd/gnu/usr.bin/perl/os2/os2_pipe.t (revision 3cab2bb3) 
1#!/usr/bin/perl -w
2BEGIN {
3    chdir 't' if -d 't';
4    @INC = '../lib';
5}
6
7use Test::More tests => 80;
8use strict;
9use IO::Handle;
10use Fcntl;
11
12my $pname = "/pipe/perl_pipe_test$$";
13
14ok !eval {OS2::pipe $pname, 'wait'}, 'wait for non-existing pipe fails';
15is 0 + $^E, 3, 'correct error code';
16ok my $server_pipe = OS2::pipe($pname, 'rw'), 'create pipe, no connect';
17ok((my $fd = fileno $server_pipe) >= 0, 'has a fileno');
18is +(OS2::pipeCntl($server_pipe, 'readstate'))[0], 2, 'is listening';
19is OS2::pipeCntl($server_pipe, 'state') & 0xFF, 1, 'max count=1';
20
21ok 0 > OS2::pipeCntl($server_pipe, 'connect', !'wait'), 'connect nowait';
22
23ok open(my $fh, '+<', $pname), 'open client end';
24#ok sysopen($fh, $pname, O_RDWR), 'sysopen client end' . $^E;
25#my ($fd1, $action) = OS2::open $pname, 0x2042 or warn $^E; # ERROR,SHARE,RDWR
26is +(OS2::pipeCntl($server_pipe, 'readstate'))[0], 3, 'is connected';
27ok 0 < OS2::pipeCntl($server_pipe, 'connect', !'wait'), 'connect nowait';
28ok OS2::pipeCntl($server_pipe, 'connect', 'wait'), 'connect wait';
29is $server_pipe->autoflush, 0, 'autoflush server'; # Returns the old value
30is $fh->autoflush, 0, 'autoflush';	# Returns the old value
31ok syswrite($server_pipe, "some string\n"), 'server write';
32is scalar <$fh>, "some string\n", 'client read';
33ok syswrite($fh, "another string\n"), 'client write';
34
35is OS2::pipeCntl($server_pipe, 'peek'), "another string\n", 'peeking is fine';
36my ($st, $bytesAvail, $bytesInMess) = OS2::pipeCntl($server_pipe, 'readstate');
37my ($name, $remoteID, $outBuffer, $inBuffer, $maxInstance, $countInstance)
38  = OS2::pipeCntl($server_pipe, 'info');
39is $bytesAvail, length("another string\n"), 'count bytes';
40is $remoteID, 0, 'not remote';
41is $maxInstance, 1, 'max count is 1';
42is $countInstance, 1, 'count is 1';
43#is $len, length($pname) + 1, 'length of name is 1 more than the actual';
44(my $tmp = $pname) =~ s,/,\\,g;
45is lc $name, lc $tmp, 'name is correct (up to case)';
46
47# If do print() instead of syswrite(), this gets "some string\n" instead!!!
48is scalar <$server_pipe>, "another string\n", 'server read';
49
50ok !open(my $fh1, '+<', $pname), 'open client end fails';
51
52# No new child present, return -1
53ok 0 > OS2::pipeCntl($server_pipe, 'reset', !'wait'), 'server reset, no wait';
54ok eof($fh), 'client EOF';
55ok(($fh->clearerr, 1), 'client clear EOF');	# XXXX Returns void
56
57$!=0; $^E = 0;
58ok close $fh, 'close client';
59#diag $!;
60#diag $^E;
61is fileno $fh, undef, 'was actually closed...';
62
63ok open($fh, '+<', $pname), 'open client end';
64
65is $fh->autoflush, 1, 'autoflush';	# Returns the old value
66ok syswrite($server_pipe, "some string\n"), 'server write';
67is scalar <$fh>, "some string\n", 'client read';
68ok syswrite($fh, "another string\n"), 'client write';
69
70# If do print() instead of syswrite(), this gets "some string\n" instead!!!
71is scalar <$server_pipe>, "another string\n", 'server read';
72
73ok syswrite($server_pipe, "some string\n"), 'server write';
74ok syswrite($fh, "another string\n"), 'client write';
75is scalar <$fh>, "some string\n", 'client read';
76
77# If do print() instead of syswrite(), this gets "some string\n" instead!!!
78is scalar <$server_pipe>, "another string\n", 'server read';
79
80ok syswrite($server_pipe, "some string\n"), 'server write';
81ok syswrite($fh, "another string\n"), 'client write';
82
83ok((sysread $fh, my $in, 2000), 'client sysread');
84is $in, "some string\n", 'client sysread correct';
85
86# If do print() instead of syswrite(), this gets "some string\n" instead!!!
87ok((sysread $server_pipe, $in, 2000), 'server sysread');
88is $in, "another string\n", 'server sysread correct';
89
90ok !open($fh1, '+<', $pname), 'open client end fails';
91
92# XXXX Not needed???
93#ok(($fh->clearerr, 1), 'client clear EOF');	# XXXX Returns void
94
95ok close $fh, 'close client';
96ok eof $server_pipe, 'server EOF';	# Creates an error condition
97
98my $pid = system 4|0x40000, $^X, '-wle', <<'EOS', $pname; # SESSION|INDEPENDENT
99  my $success;
100  END {sleep($success ? 1 : 10);}
101  my $mess = '';
102  $SIG{TERM} = sub {die "kid1 error: Got SIGTERM\nmess=`$mess'"};
103  my $pn = shift;
104  my $fh;
105  eval {
106    $mess .= "Pipe open fails\n" unless open $fh, '+<', $pn;
107    my $t = time;		### TIMESTAMP0
108    warn "kid1: Wait for pipe...\n";
109    $mess .= "Pipe became available\n" if OS2::pipe $pn, 'wait';
110    my $t1 = time() - $t;	### TIMESTAMP1
111    $mess .= "Unexpected delay $t1\n" unless $t1 >= 1 and $t1 <= 3;
112    warn "kid1: sleep 4...\n";
113    sleep 4;
114    $mess .= "Pipe open\n" if open $fh, '+<', $pn;
115    binmode $fh;
116    1;				### TIMESTAMP2
117  } or warn $@;
118  warn "kid1: pipe opened...\n";
119  select $fh; $| = 1;
120  my $c = syswrite $fh, $mess or warn "print: $!";
121  warn "kid1: Wrote $c bytes\n";
122  warn $mess;
123  close $fh or die "kid1 error: close: $!";
124  $success = 1;
125EOS
126
127ok $pid > 0, 'kid pid';
128
129### TIMESTAMP0
130sleep 2;
131my $t = time;
132### TIMESTAMP1
133# New child present; will clear error condition...
134ok 0 < OS2::pipeCntl($server_pipe, 'reset', 'wait'), 'server reset, wait';
135### TIMESTAMP2
136my $t1 = time() - $t;
137ok $t1 <= 6 && $t1 >= 2, 'correct delay';
138
139sleep 2;
140
141ok binmode($server_pipe), 'binmode';
142ok !eof $server_pipe, 'server: no EOF';
143my @in = <$server_pipe>;
144my @exp = ( "Pipe open fails\n", "Pipe became available\n", "Pipe open\n");
145
146is "@in", "@exp", 'expected data';
147
148# Can't switch to message mode if created in byte mode...
149ok close $server_pipe, 'server close';
150ok $server_pipe = OS2::pipe($pname, 'RW'), 'create pipe in message mode';
151ok OS2::pipeCntl($server_pipe, 'byte'),    'can switch to byte mode';
152ok OS2::pipeCntl($server_pipe, 'message'), 'can switch to message mode';
153
154$pid = system 4|0x40000, $^X, '-wle', <<'EOS', $pname, $$; # SESSION|INDEPENDENT
155  END {sleep 2}
156  my ($name, $ppid) = (shift, shift);
157  $name =~ s,/,\\,g;
158  $name = uc $name;
159  warn "kid2: OS2::pipe $name, 'call', ...\n";
160  my $got = OS2::pipe $name, 'call', "Is your pid $ppid?\n";
161  my $ok = $got eq 'Yes';
162  warn "kid2: got `$got'\n";
163  OS2::pipe $name, 'call', $ok ? "fine\n" : "bad\n";
164EOS
165
166ok $pid, 'kid started';
167sleep 2;			# XXX How to synchronize with kid???
168$in = scalar <$server_pipe>;
169my $ok1 = ($in || '') eq "Is your pid $$?\n";
170is $in, "Is your pid $$?\n", 'call in';
171ok syswrite($server_pipe, $ok1 ? 'Yes' : 'No' ), 'server write';
172
173ok 0 < OS2::pipeCntl($server_pipe, 'reset', 'wait'), 'server reset, wait';
174$in = scalar <$server_pipe>;
175is $in, "fine\n", 'call in';
176ok syswrite($server_pipe, 'ending' ), 'server write';
177
178ok close $server_pipe, 'server close';
179
180ok $server_pipe = OS2::pipe($pname, 'W'), 'create pipe in message write mode';
181ok !eval {OS2::pipeCntl($server_pipe, 'readstate'); 1}, 'readstate fails, as expected';
182ok close $server_pipe, 'server close';
183
184ok $server_pipe = OS2::pipe($pname, 'w'), 'create pipe in byte write mode';
185ok !eval {OS2::pipeCntl($server_pipe, 'readstate'); 1}, 'readstate fails, as expected';
186ok close $server_pipe, 'server close';
187
188ok $server_pipe = OS2::pipe($pname, 'r'), 'create pipe in byte read mode';
189is +(OS2::pipeCntl($server_pipe, 'readstate'))[0], 2, 'is listening';
190ok close $server_pipe, 'server close';
191
192ok $server_pipe = OS2::pipe($pname, 'r', 0), 'create-no-connect pipe in byte read mode';
193is +(OS2::pipeCntl($server_pipe, 'readstate'))[0], 1, 'is disconnected';
194ok close $server_pipe, 'server close';
195
196ok $server_pipe = OS2::pipe($pname, 'R'), 'create pipe in message read mode';
197is +(OS2::pipeCntl($server_pipe, 'readstate'))[0], 2, 'is listening';
198ok close $server_pipe, 'server close';
199
200#is waitpid($pid, 0), $pid, 'kid ended';
201#is $?, 0, 'kid exitcode';
202