os2/os2_pipe.t

   1 #!/usr/bin/perl -w
   2 BEGIN {
   3     chdir 't' if -d 't';
   4     @INC = '../lib';
   5 }
   6
   7 use Test::More tests => 80;
   8 use strict;
   9 use IO::Handle;
  10 use Fcntl;
  11
  12 my $pname = "/pipe/perl_pipe_test$$";
  13
  14 ok !eval {OS2::pipe $pname, 'wait'}, 'wait for non-existing pipe fails';
  15 is 0 + $^E, 3, 'correct error code';
  16 ok my $server_pipe = OS2::pipe($pname, 'rw'), 'create pipe, no connect';
  17 ok((my $fd = fileno $server_pipe) >= 0, 'has a fileno');
  18 is +(OS2::pipeCntl($server_pipe, 'readstate'))[0], 2, 'is listening';
  19 is OS2::pipeCntl($server_pipe, 'state') & 0xFF, 1, 'max count=1';
  20
  21 ok 0 > OS2::pipeCntl($server_pipe, 'connect', !'wait'), 'connect nowait';
  22
  23 ok 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
  26 is +(OS2::pipeCntl($server_pipe, 'readstate'))[0], 3, 'is connected';
  27 ok 0 < OS2::pipeCntl($server_pipe, 'connect', !'wait'), 'connect nowait';
  28 ok OS2::pipeCntl($server_pipe, 'connect', 'wait'), 'connect wait';
  29 is $server_pipe->autoflush, 0, 'autoflush server'; # Returns the old value
  30 is $fh->autoflush, 0, 'autoflush';      # Returns the old value
  31 ok syswrite($server_pipe, "some string\n"), 'server write';
  32 is scalar <$fh>, "some string\n", 'client read';
  33 ok syswrite($fh, "another string\n"), 'client write';
  34
  35 is OS2::pipeCntl($server_pipe, 'peek'), "another string\n", 'peeking is fine';
  36 my ($st, $bytesAvail, $bytesInMess) = OS2::pipeCntl($server_pipe, 'readstate');
  37 my ($name, $remoteID, $outBuffer, $inBuffer, $maxInstance, $countInstance)
  38   = OS2::pipeCntl($server_pipe, 'info');
  39 is $bytesAvail, length("another string\n"), 'count bytes';
  40 is $remoteID, 0, 'not remote';
  41 is $maxInstance, 1, 'max count is 1';
  42 is $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;
  45 is lc $name, lc $tmp, 'name is correct (up to case)';
  46
  47 # If do print() instead of syswrite(), this gets "some string\n" instead!!!
  48 is scalar <$server_pipe>, "another string\n", 'server read';
  49
  50 ok !open(my $fh1, '+<', $pname), 'open client end fails';
  51
  52 # No new child present, return -1
  53 ok 0 > OS2::pipeCntl($server_pipe, 'reset', !'wait'), 'server reset, no wait';
  54 ok eof($fh), 'client EOF';
  55 ok(($fh->clearerr, 1), 'client clear EOF');     # XXXX Returns void
  56
  57 $!=0; $^E = 0;
  58 ok close $fh, 'close client';
  59 #diag $!;
  60 #diag $^E;
  61 is fileno $fh, undef, 'was actually closed...';
  62
  63 ok open($fh, '+<', $pname), 'open client end';
  64
  65 is $fh->autoflush, 1, 'autoflush';      # Returns the old value
  66 ok syswrite($server_pipe, "some string\n"), 'server write';
  67 is scalar <$fh>, "some string\n", 'client read';
  68 ok syswrite($fh, "another string\n"), 'client write';
  69
  70 # If do print() instead of syswrite(), this gets "some string\n" instead!!!
  71 is scalar <$server_pipe>, "another string\n", 'server read';
  72
  73 ok syswrite($server_pipe, "some string\n"), 'server write';
  74 ok syswrite($fh, "another string\n"), 'client write';
  75 is scalar <$fh>, "some string\n", 'client read';
  76
  77 # If do print() instead of syswrite(), this gets "some string\n" instead!!!
  78 is scalar <$server_pipe>, "another string\n", 'server read';
  79
  80 ok syswrite($server_pipe, "some string\n"), 'server write';
  81 ok syswrite($fh, "another string\n"), 'client write';
  82
  83 ok((sysread $fh, my $in, 2000), 'client sysread');
  84 is $in, "some string\n", 'client sysread correct';
  85
  86 # If do print() instead of syswrite(), this gets "some string\n" instead!!!
  87 ok((sysread $server_pipe, $in, 2000), 'server sysread');
  88 is $in, "another string\n", 'server sysread correct';
  89
  90 ok !open($fh1, '+<', $pname), 'open client end fails';
  91
  92 # XXXX Not needed???
  93 #ok(($fh->clearerr, 1), 'client clear EOF');    # XXXX Returns void
  94
  95 ok close $fh, 'close client';
  96 ok eof $server_pipe, 'server EOF';      # Creates an error condition
  97
  98 my $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;
 125 EOS
 126
 127 ok $pid > 0, 'kid pid';
 128
 129 ### TIMESTAMP0
 130 sleep 2;
 131 my $t = time;
 132 ### TIMESTAMP1
 133 # New child present; will clear error condition...
 134 ok 0 < OS2::pipeCntl($server_pipe, 'reset', 'wait'), 'server reset, wait';
 135 ### TIMESTAMP2
 136 my $t1 = time() - $t;
 137 ok $t1 <= 6 && $t1 >= 2, 'correct delay';
 138
 139 sleep 2;
 140
 141 ok binmode($server_pipe), 'binmode';
 142 ok !eof $server_pipe, 'server: no EOF';
 143 my @in = <$server_pipe>;
 144 my @exp = ( "Pipe open fails\n", "Pipe became available\n", "Pipe open\n");
 145
 146 is "@in", "@exp", 'expected data';
 147
 148 # Can't switch to message mode if created in byte mode...
 149 ok close $server_pipe, 'server close';
 150 ok $server_pipe = OS2::pipe($pname, 'RW'), 'create pipe in message mode';
 151 ok OS2::pipeCntl($server_pipe, 'byte'),    'can switch to byte mode';
 152 ok 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";
 164 EOS
 165
 166 ok $pid, 'kid started';
 167 sleep 2;                        # XXX How to synchronize with kid???
 168 $in = scalar <$server_pipe>;
 169 my $ok1 = ($in || '') eq "Is your pid $$?\n";
 170 is $in, "Is your pid $$?\n", 'call in';
 171 ok syswrite($server_pipe, $ok1 ? 'Yes' : 'No' ), 'server write';
 172
 173 ok 0 < OS2::pipeCntl($server_pipe, 'reset', 'wait'), 'server reset, wait';
 174 $in = scalar <$server_pipe>;
 175 is $in, "fine\n", 'call in';
 176 ok syswrite($server_pipe, 'ending' ), 'server write';
 177
 178 ok close $server_pipe, 'server close';
 179
 180 ok $server_pipe = OS2::pipe($pname, 'W'), 'create pipe in message write mode';
 181 ok !eval {OS2::pipeCntl($server_pipe, 'readstate'); 1}, 'readstate fails, as expected';
 182 ok close $server_pipe, 'server close';
 183
 184 ok $server_pipe = OS2::pipe($pname, 'w'), 'create pipe in byte write mode';
 185 ok !eval {OS2::pipeCntl($server_pipe, 'readstate'); 1}, 'readstate fails, as expected';
 186 ok close $server_pipe, 'server close';
 187
 188 ok $server_pipe = OS2::pipe($pname, 'r'), 'create pipe in byte read mode';
 189 is +(OS2::pipeCntl($server_pipe, 'readstate'))[0], 2, 'is listening';
 190 ok close $server_pipe, 'server close';
 191
 192 ok $server_pipe = OS2::pipe($pname, 'r', 0), 'create-no-connect pipe in byte read mode';
 193 is +(OS2::pipeCntl($server_pipe, 'readstate'))[0], 1, 'is disconnected';
 194 ok close $server_pipe, 'server close';
 195
 196 ok $server_pipe = OS2::pipe($pname, 'R'), 'create pipe in message read mode';
 197 is +(OS2::pipeCntl($server_pipe, 'readstate'))[0], 2, 'is listening';
 198 ok close $server_pipe, 'server close';
 199
 200 #is waitpid($pid, 0), $pid, 'kid ended';
 201 #is $?, 0, 'kid exitcode';