ext/IPC-Open3/t/IPC-Open2.t

   1 #!./perl -w
   2
   3 use Config;
   4 BEGIN {
   5     require Test::More;
   6     if (!$Config{'d_fork'}
   7        # open2/3 supported on win32
   8        && $^O ne 'MSWin32' && $^O ne 'NetWare')
   9     {
  10         Test::More->import(skip_all => 'open2/3 not available with MSWin32+Netware');
  11         exit 0;
  12     }
  13     # make warnings fatal
  14     $SIG{__WARN__} = sub { die @_ };
  15 }
  16
  17 use strict;
  18 use IPC::Open2;
  19 use Test::More tests => 15;
  20
  21 my $perl = $^X;
  22
  23 sub cmd_line {
  24         if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
  25                 return qq/"$_[0]"/;
  26         }
  27         else {
  28                 return $_[0];
  29         }
  30 }
  31
  32 STDOUT->autoflush;
  33 STDERR->autoflush;
  34
  35 my $pid = open2('READ', 'WRITE', $perl, '-e', cmd_line('print scalar <STDIN>'));
  36 cmp_ok($pid, '>', 1, 'got a sane process ID');
  37 ok(print WRITE "hi kid\n");
  38 like(<READ>, qr/^hi kid\r?\n$/);
  39 ok(close(WRITE), "closing WRITE: $!");
  40 ok(close(READ), "closing READ: $!");
  41 my $reaped_pid = waitpid $pid, 0;
  42 is($reaped_pid, $pid, "Reaped PID matches");
  43 is($?, 0, '$? should be zero');
  44
  45 {
  46     package SKREEEK;
  47     my $pid = IPC::Open2::open2('KAZOP', 'WRITE', $perl, '-e',
  48                                 main::cmd_line('print scalar <STDIN>'));
  49     main::cmp_ok($pid, '>', 1, 'got a sane process ID');
  50     main::ok(print WRITE "hi kid\n");
  51     main::like(<KAZOP>, qr/^hi kid\r?\n$/);
  52     main::ok(close(WRITE), "closing WRITE: $!");
  53     main::ok(close(KAZOP), "closing READ: $!");
  54     my $reaped_pid = waitpid $pid, 0;
  55     main::is($reaped_pid, $pid, "Reaped PID matches");
  56     main::is($?, 0, '$? should be zero');
  57 }
  58
  59 $pid = eval { open2('READ', '', $perl, '-e', cmd_line('print scalar <STDIN>')) };
  60 like($@, qr/^open2: Modification of a read-only value attempted at /,
  61      'open2 faults read-only parameters correctly') or do {waitpid $pid, 0};