1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = qw(. ../lib); 6 require "./test.pl"; 7} 8 9use Config; 10no warnings 'once'; 11 12my $test = 1; 13my $tests_needing_perlio = 17; 14plan(12 + $tests_needing_perlio); 15print "ok 1\n"; 16 17open(DUPOUT,">&STDOUT"); 18open(DUPERR,">&STDERR"); 19 20open(STDOUT,">Io.dup") || die "Can't open stdout"; 21open(STDERR,">&STDOUT") || die "Can't open stderr"; 22 23select(STDERR); $| = 1; 24select(STDOUT); $| = 1; 25 26print STDOUT "ok 2\n"; 27print STDERR "ok 3\n"; 28 29# Since some systems don't have echo, we use Perl. 30$echo = qq{$^X -le "print q(ok %d)"}; 31 32$cmd = sprintf $echo, 4; 33print `$cmd`; 34 35$cmd = sprintf "$echo 1>&2", 5; 36$cmd = sprintf $echo, 5 if $^O eq 'MacOS'; # don't know if we can do this ... 37print `$cmd`; 38 39# KNOWN BUG system() does not honor STDOUT redirections on VMS. 40if( $^O eq 'VMS' ) { 41 print "not ok $_ # TODO system() not honoring STDOUT redirect on VMS\n" 42 for 6..7; 43} 44else { 45 system sprintf $echo, 6; 46 if ($^O eq 'MacOS') { 47 system sprintf $echo, 7; 48 } 49 else { 50 system sprintf "$echo 1>&2", 7; 51 } 52} 53 54close(STDOUT) or die "Could not close: $!"; 55close(STDERR) or die "Could not close: $!"; 56 57open(STDOUT,">&DUPOUT") or die "Could not open: $!"; 58open(STDERR,">&DUPERR") or die "Could not open: $!"; 59 60if (($^O eq 'MSWin32') || ($^O eq 'NetWare') || ($^O eq 'VMS')) { print `type Io.dup` } 61elsif ($^O eq 'MacOS') { system 'catenate Io.dup' } 62else { system 'cat Io.dup' } 63unlink 'Io.dup'; 64 65print STDOUT "ok 8\n"; 66 67open(F,">&",1) or die "Cannot dup to numeric 1: $!"; 68print F "ok 9\n"; 69close(F); 70 71open(F,">&",'1') or die "Cannot dup to string '1': $!"; 72print F "ok 10\n"; 73close(F); 74 75open(F,">&=",1) or die "Cannot dup to numeric 1: $!"; 76print F "ok 11\n"; 77close(F); 78 79if ($Config{useperlio}) { 80 open(F,">&=",'1') or die "Cannot dup to string '1': $!"; 81 print F "ok 12\n"; 82 close(F); 83} else { 84 open(F, ">&DUPOUT") or die "Cannot dup stdout back: $!"; 85 print F "ok 12\n"; 86 close(F); 87} 88 89# To get STDOUT back. 90open(F, ">&DUPOUT") or die "Cannot dup stdout back: $!"; 91 92curr_test(13); 93 94SKIP: { 95 skip("need perlio", $tests_needing_perlio) unless $Config{useperlio}; 96 97 ok(open(F, ">&", STDOUT)); 98 isnt(fileno(F), fileno(STDOUT)); 99 close F; 100 101 ok(open(F, "<&=STDIN")) or _diag $!; 102 is(fileno(F), fileno(STDIN)); 103 close F; 104 105 ok(open(F, ">&=STDOUT")); 106 is(fileno(F), fileno(STDOUT)); 107 close F; 108 109 ok(open(F, ">&=STDERR")); 110 is(fileno(F), fileno(STDERR)); 111 close F; 112 113 open(G, ">dup$$") or die; 114 my $g = fileno(G); 115 116 ok(open(F, ">&=$g")); 117 is(fileno(F), $g); 118 close F; 119 120 ok(open(F, ">&=G")); 121 is(fileno(F), $g); 122 123 print G "ggg\n"; 124 print F "fff\n"; 125 126 close G; # flush first 127 close F; # flush second 128 129 open(G, "<dup$$") or die; 130 { 131 my $line; 132 $line = <G>; chomp $line; is($line, "ggg"); 133 $line = <G>; chomp $line; is($line, "fff"); 134 } 135 close G; 136 137 open UTFOUT, '>:utf8', "dup$$" or die $!; 138 open UTFDUP, '>&UTFOUT' or die $!; 139 # some old greek saying. 140 my $message = "\x{03A0}\x{0391}\x{039D}\x{03A4}\x{0391} \x{03A1}\x{0395}\x{0399}\n"; 141 print UTFOUT $message; 142 print UTFDUP $message; 143 binmode UTFDUP, ':utf8'; 144 print UTFDUP $message; 145 close UTFOUT; 146 close UTFDUP; 147 open(UTFIN, "<:utf8", "dup$$") or die $!; 148 { 149 my $line; 150 $line = <UTFIN>; is($line, $message); 151 $line = <UTFIN>; is($line, $message); 152 $line = <UTFIN>; is($line, $message); 153 } 154 close UTFIN; 155 156 END { 1 while unlink "dup$$" } 157} 158