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

   1 #!./perl -w
   2
   3 BEGIN {
   4     require Config; import Config;
   5     if (!$Config{'d_fork'}
   6        # open2/3 supported on win32
   7        && $^O ne 'MSWin32' && $^O ne 'NetWare')
   8     {
   9         print "1..0\n";
  10         exit 0;
  11     }
  12     # make warnings fatal
  13     $SIG{__WARN__} = sub { die @_ };
  14 }
  15
  16 use strict;
  17 use Test::More tests => 37;
  18
  19 use IO::Handle;
  20 use IPC::Open3;
  21
  22 my $perl = $^X;
  23
  24 sub cmd_line {
  25         if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
  26                 my $cmd = shift;
  27                 $cmd =~ tr/\r\n//d;
  28                 $cmd =~ s/"/\\"/g;
  29                 return qq/"$cmd"/;
  30         }
  31         else {
  32                 return $_[0];
  33         }
  34 }
  35
  36 my ($pid, $reaped_pid);
  37 STDOUT->autoflush;
  38 STDERR->autoflush;
  39
  40 # basic
  41 $pid = open3 'WRITE', 'READ', 'ERROR', $perl, '-e', cmd_line(<<'EOF');
  42     $| = 1;
  43     print scalar <STDIN>;
  44     print STDERR "hi error\n";
  45 EOF
  46 cmp_ok($pid, '!=', 0);
  47 isnt((print WRITE "hi kid\n"), 0);
  48 like(scalar <READ>, qr/^hi kid\r?\n$/);
  49 like(scalar <ERROR>, qr/^hi error\r?\n$/);
  50 is(close(WRITE), 1) or diag($!);
  51 is(close(READ), 1) or diag($!);
  52 is(close(ERROR), 1) or diag($!);
  53 $reaped_pid = waitpid $pid, 0;
  54 is($reaped_pid, $pid);
  55 is($?, 0);
  56
  57 my $desc = "read and error together, both named";
  58 $pid = open3 'WRITE', 'READ', 'READ', $perl, '-e', cmd_line(<<'EOF');
  59     $| = 1;
  60     print scalar <STDIN>;
  61     print STDERR scalar <STDIN>;
  62 EOF
  63 print WRITE "$desc\n";
  64 like(scalar <READ>, qr/\A$desc\r?\n\z/);
  65 print WRITE "$desc [again]\n";
  66 like(scalar <READ>, qr/\A$desc \[again\]\r?\n\z/);
  67 waitpid $pid, 0;
  68
  69 $desc = "read and error together, error empty";
  70 $pid = open3 'WRITE', 'READ', '', $perl, '-e', cmd_line(<<'EOF');
  71     $| = 1;
  72     print scalar <STDIN>;
  73     print STDERR scalar <STDIN>;
  74 EOF
  75 print WRITE "$desc\n";
  76 like(scalar <READ>, qr/\A$desc\r?\n\z/);
  77 print WRITE "$desc [again]\n";
  78 like(scalar <READ>, qr/\A$desc \[again\]\r?\n\z/);
  79 waitpid $pid, 0;
  80
  81 is(pipe(PIPE_READ, PIPE_WRITE), 1);
  82 $pid = open3 '<&PIPE_READ', 'READ', '',
  83                     $perl, '-e', cmd_line('print scalar <STDIN>');
  84 close PIPE_READ;
  85 print PIPE_WRITE "dup writer\n";
  86 close PIPE_WRITE;
  87 like(scalar <READ>, qr/\Adup writer\r?\n\z/);
  88 waitpid $pid, 0;
  89
  90 my $TB = Test::Builder->new();
  91 my $test = $TB->current_test;
  92 # dup reader
  93 $pid = open3 'WRITE', '>&STDOUT', 'ERROR',
  94                     $perl, '-e', cmd_line('print scalar <STDIN>');
  95 ++$test;
  96 print WRITE "ok $test\n";
  97 waitpid $pid, 0;
  98
  99 {
 100     package YAAH;
 101     $pid = IPC::Open3::open3('QWACK_WAAK_WAAK', '>&STDOUT', 'ERROR',
 102                              $perl, '-e', main::cmd_line('print scalar <STDIN>'));
 103     ++$test;
 104     no warnings 'once';
 105     print QWACK_WAAK_WAAK "ok $test # filenames qualified to their package\n";
 106     waitpid $pid, 0;
 107 }
 108
 109 # dup error:  This particular case, duping stderr onto the existing
 110 # stdout but putting stdout somewhere else, is a good case because it
 111 # used not to work.
 112 $pid = open3 'WRITE', 'READ', '>&STDOUT',
 113                     $perl, '-e', cmd_line('print STDERR scalar <STDIN>');
 114 ++$test;
 115 print WRITE "ok $test\n";
 116 waitpid $pid, 0;
 117
 118 foreach (['>&STDOUT', 'both named'],
 119          ['', 'error empty'],
 120         ) {
 121     my ($err, $desc) = @$_;
 122     $pid = open3 'WRITE', '>&STDOUT', $err, $perl, '-e', cmd_line(<<'EOF');
 123     $| = 1;
 124     print STDOUT scalar <STDIN>;
 125     print STDERR scalar <STDIN>;
 126 EOF
 127     printf WRITE "ok %d # dup reader and error together, $desc\n", ++$test
 128         for 0, 1;
 129     waitpid $pid, 0;
 130 }
 131
 132 # command line in single parameter variant of open3
 133 # for understanding of Config{'sh'} test see exec description in camel book
 134 my $cmd = 'print(scalar(<STDIN>))';
 135 $cmd = $Config{'sh'} =~ /sh/ ? "'$cmd'" : cmd_line($cmd);
 136 $pid = eval { open3 'WRITE', '>&STDOUT', 'ERROR', "$perl -e " . $cmd; };
 137 if ($@) {
 138         print "error $@\n";
 139         ++$test;
 140         print WRITE "not ok $test\n";
 141 }
 142 else {
 143         ++$test;
 144         print WRITE "ok $test\n";
 145         waitpid $pid, 0;
 146 }
 147 $TB->current_test($test);
 148
 149 # RT 72016
 150 {
 151     local $::TODO = "$^O returns a pid and doesn't throw an exception"
 152         if $^O eq 'MSWin32';
 153     $pid = eval { open3 'WRITE', 'READ', 'ERROR', '/non/existent/program'; };
 154     isnt($@, '',
 155          'open3 of a non existent program fails with an exception in the parent')
 156         or do {waitpid $pid, 0};
 157 }
 158
 159 $pid = eval { open3 'WRITE', '', 'ERROR', '/non/existent/program'; };
 160 like($@, qr/^open3: Modification of a read-only value attempted at /,
 161      'open3 faults read-only parameters correctly') or do {waitpid $pid, 0};
 162
 163 foreach my $handle (qw (DUMMY STDIN STDOUT STDERR)) {
 164     local $::{$handle};
 165     my $out = IO::Handle->new();
 166     my $pid = eval {
 167         local $SIG{__WARN__} = sub {
 168             open my $fh, '>/dev/tty';
 169             return if "@_" =~ m!^Use of uninitialized value \$fd.*IO/Handle\.pm!;
 170             print $fh "@_";
 171             die @_
 172         };
 173         open3 undef, $out, undef, $perl, '-le', "print q _# ${handle}_"
 174     };
 175     is($@, '', "No errors with localised $handle");
 176     cmp_ok($pid, '>', 0, "Got a pid with localised $handle");
 177     if ($handle eq 'STDOUT') {
 178         is(<$out>, undef, "Expected no output with localised $handle");
 179     } else {
 180         like(<$out>, qr/\A# $handle\r?\n\z/,
 181              "Expected output with localised $handle");
 182     }
 183     waitpid $pid, 0;
 184 }