1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7} 8 9$| = 1; 10use warnings; 11use Config; 12$Is_VMS = $^O eq 'VMS'; 13$Is_MacOS = $^O eq 'MacOS'; 14 15plan tests => 107; 16 17my $Perl = which_perl(); 18 19{ 20 unlink("afile") if -f "afile"; 21 22 $! = 0; # the -f above will set $! if 'afile' doesn't exist. 23 ok( open(my $f,"+>afile"), 'open(my $f, "+>...")' ); 24 25 binmode $f; 26 ok( -f "afile", ' its a file'); 27 ok( (print $f "SomeData\n"), ' we can print to it'); 28 is( tell($f), 9, ' tell()' ); 29 ok( seek($f,0,0), ' seek set' ); 30 31 $b = <$f>; 32 is( $b, "SomeData\n", ' readline' ); 33 ok( -f $f, ' still a file' ); 34 35 eval { die "Message" }; 36 like( $@, qr/<\$f> line 1/, ' die message correct' ); 37 38 ok( close($f), ' close()' ); 39 ok( unlink("afile"), ' unlink()' ); 40} 41 42{ 43 ok( open(my $f,'>', 'afile'), "open(my \$f, '>', 'afile')" ); 44 ok( (print $f "a row\n"), ' print'); 45 ok( close($f), ' close' ); 46 ok( -s 'afile' < 10, ' -s' ); 47} 48 49{ 50 ok( open(my $f,'>>', 'afile'), "open(my \$f, '>>', 'afile')" ); 51 ok( (print $f "a row\n"), ' print' ); 52 ok( close($f), ' close' ); 53 ok( -s 'afile' > 10, ' -s' ); 54} 55 56{ 57 ok( open(my $f, '<', 'afile'), "open(my \$f, '<', 'afile')" ); 58 my @rows = <$f>; 59 is( scalar @rows, 2, ' readline, list context' ); 60 is( $rows[0], "a row\n", ' first line read' ); 61 is( $rows[1], "a row\n", ' second line' ); 62 ok( close($f), ' close' ); 63} 64 65{ 66 ok( -s 'afile' < 20, '-s' ); 67 68 ok( open(my $f, '+<', 'afile'), 'open +<' ); 69 my @rows = <$f>; 70 is( scalar @rows, 2, ' readline, list context' ); 71 ok( seek($f, 0, 1), ' seek cur' ); 72 ok( (print $f "yet another row\n"), ' print' ); 73 ok( close($f), ' close' ); 74 ok( -s 'afile' > 20, ' -s' ); 75 76 unlink("afile"); 77} 78 79SKIP: { 80 skip "open -| busted and noisy on VMS", 3 if $Is_VMS; 81 82 ok( open(my $f, '-|', <<EOC), 'open -|' ); 83 $Perl -e "print qq(a row\\n); print qq(another row\\n)" 84EOC 85 86 my @rows = <$f>; 87 is( scalar @rows, 2, ' readline, list context' ); 88 ok( close($f), ' close' ); 89} 90 91SKIP: { 92 skip "Output for |- doesn't go to shell on MacOS", 5 if $Is_MacOS; 93 94 ok( open(my $f, '|-', <<EOC), 'open |-' ); 95 $Perl -pe "s/^not //" 96EOC 97 98 my @rows = <$f>; 99 my $test = curr_test; 100 print $f "not ok $test - piped in\n"; 101 next_test; 102 103 $test = curr_test; 104 print $f "not ok $test - piped in\n"; 105 next_test; 106 ok( close($f), ' close' ); 107 sleep 1; 108 pass('flushing'); 109} 110 111 112ok( !eval { open my $f, '<&', 'afile'; 1; }, '<& on a non-filehandle' ); 113like( $@, qr/Bad filehandle:\s+afile/, ' right error' ); 114 115 116# local $file tests 117{ 118 unlink("afile") if -f "afile"; 119 120 ok( open(local $f,"+>afile"), 'open local $f, "+>", ...' ); 121 binmode $f; 122 123 ok( -f "afile", ' -f' ); 124 ok( (print $f "SomeData\n"), ' print' ); 125 is( tell($f), 9, ' tell' ); 126 ok( seek($f,0,0), ' seek set' ); 127 128 $b = <$f>; 129 is( $b, "SomeData\n", ' readline' ); 130 ok( -f $f, ' still a file' ); 131 132 eval { die "Message" }; 133 like( $@, qr/<\$f> line 1/, ' proper die message' ); 134 ok( close($f), ' close' ); 135 136 unlink("afile"); 137} 138 139{ 140 ok( open(local $f,'>', 'afile'), 'open local $f, ">", ...' ); 141 ok( (print $f "a row\n"), ' print'); 142 ok( close($f), ' close'); 143 ok( -s 'afile' < 10, ' -s' ); 144} 145 146{ 147 ok( open(local $f,'>>', 'afile'), 'open local $f, ">>", ...' ); 148 ok( (print $f "a row\n"), ' print'); 149 ok( close($f), ' close'); 150 ok( -s 'afile' > 10, ' -s' ); 151} 152 153{ 154 ok( open(local $f, '<', 'afile'), 'open local $f, "<", ...' ); 155 my @rows = <$f>; 156 is( scalar @rows, 2, ' readline list context' ); 157 ok( close($f), ' close' ); 158} 159 160ok( -s 'afile' < 20, ' -s' ); 161 162{ 163 ok( open(local $f, '+<', 'afile'), 'open local $f, "+<", ...' ); 164 my @rows = <$f>; 165 is( scalar @rows, 2, ' readline list context' ); 166 ok( seek($f, 0, 1), ' seek cur' ); 167 ok( (print $f "yet another row\n"), ' print' ); 168 ok( close($f), ' close' ); 169 ok( -s 'afile' > 20, ' -s' ); 170 171 unlink("afile"); 172} 173 174SKIP: { 175 skip "open -| busted and noisy on VMS", 3 if $Is_VMS; 176 177 ok( open(local $f, '-|', <<EOC), 'open local $f, "-|", ...' ); 178 $Perl -e "print qq(a row\\n); print qq(another row\\n)" 179EOC 180 my @rows = <$f>; 181 182 is( scalar @rows, 2, ' readline list context' ); 183 ok( close($f), ' close' ); 184} 185 186SKIP: { 187 skip "Output for |- doesn't go to shell on MacOS", 5 if $Is_MacOS; 188 189 ok( open(local $f, '|-', <<EOC), 'open local $f, "|-", ...' ); 190 $Perl -pe "s/^not //" 191EOC 192 193 my @rows = <$f>; 194 my $test = curr_test; 195 print $f "not ok $test - piping\n"; 196 next_test; 197 198 $test = curr_test; 199 print $f "not ok $test - piping\n"; 200 next_test; 201 ok( close($f), ' close' ); 202 sleep 1; 203 pass("Flush"); 204} 205 206 207ok( !eval { open local $f, '<&', 'afile'; 1 }, 'local <& on non-filehandle'); 208like( $@, qr/Bad filehandle:\s+afile/, ' right error' ); 209 210{ 211 local *F; 212 for (1..2) { 213 ok( open(F, qq{$Perl -le "print 'ok'"|}), 'open to pipe' ); 214 is(scalar <F>, "ok\n", ' readline'); 215 ok( close F, ' close' ); 216 } 217 218 for (1..2) { 219 ok( open(F, "-|", qq{$Perl -le "print 'ok'"}), 'open -|'); 220 is( scalar <F>, "ok\n", ' readline'); 221 ok( close F, ' close' ); 222 } 223} 224 225 226# other dupping techniques 227{ 228 ok( open(my $stdout, ">&", \*STDOUT), 'dup \*STDOUT into lexical fh'); 229 ok( open(STDOUT, ">&", $stdout), 'restore dupped STDOUT from lexical fh'); 230 231 { 232 use strict; # the below should not warn 233 ok( open(my $stdout, ">&", STDOUT), 'dup STDOUT into lexical fh'); 234 } 235 236 # used to try to open a file [perl #17830] 237 ok( open(my $stdin, "<&", fileno STDIN), 'dup fileno(STDIN) into lexical fh'); 238} 239 240SKIP: { 241 skip "This perl uses perlio", 1 if $Config{useperlio}; 242 skip "miniperl cannot be relied on to load %Errno" 243 if $ENV{PERL_CORE_MINITEST}; 244 # Force the reference to %! to be run time by writing ! as {"!"} 245 skip "This system doesn't understand EINVAL", 1 246 unless exists ${"!"}{EINVAL}; 247 248 no warnings 'io'; 249 ok(!open(F,'>',\my $s) && ${"!"}{EINVAL}, 'open(reference) raises EINVAL'); 250} 251 252{ 253 ok( !eval { open F, "BAR", "QUUX" }, 'Unknown open() mode' ); 254 like( $@, qr/\QUnknown open() mode 'BAR'/, ' right error' ); 255} 256 257{ 258 local $SIG{__WARN__} = sub { $@ = shift }; 259 260 sub gimme { 261 my $tmphandle = shift; 262 my $line = scalar <$tmphandle>; 263 warn "gimme"; 264 return $line; 265 } 266 267 open($fh0[0], "TEST"); 268 gimme($fh0[0]); 269 like($@, qr/<\$fh0\[...\]> line 1\./, "autoviv fh package aelem"); 270 271 open($fh1{k}, "TEST"); 272 gimme($fh1{k}); 273 like($@, qr/<\$fh1{...}> line 1\./, "autoviv fh package helem"); 274 275 my @fh2; 276 open($fh2[0], "TEST"); 277 gimme($fh2[0]); 278 like($@, qr/<\$fh2\[...\]> line 1\./, "autoviv fh lexical aelem"); 279 280 my %fh3; 281 open($fh3{k}, "TEST"); 282 gimme($fh3{k}); 283 like($@, qr/<\$fh3{...}> line 1\./, "autoviv fh lexical helem"); 284} 285 286SKIP: { 287 skip("These tests use perlio", 5) unless $Config{useperlio}; 288 my $w; 289 use warnings 'layer'; 290 local $SIG{__WARN__} = sub { $w = shift }; 291 292 eval { open(F, ">>>", "afile") }; 293 like($w, qr/Invalid separator character '>' in PerlIO layer spec/, 294 "bad open (>>>) warning"); 295 like($@, qr/Unknown open\(\) mode '>>>'/, 296 "bad open (>>>) failure"); 297 298 eval { open(F, ">:u", "afile" ) }; 299 like($w, qr/Unknown PerlIO layer "u"/, 300 'bad layer ">:u" warning'); 301 eval { open(F, "<:u", "afile" ) }; 302 like($w, qr/Unknown PerlIO layer "u"/, 303 'bad layer "<:u" warning'); 304 eval { open(F, ":c", "afile" ) }; 305 like($@, qr/Unknown open\(\) mode ':c'/, 306 'bad layer ":c" failure'); 307} 308 309# [perl #28986] "open m" crashes Perl 310 311fresh_perl_like('open m', qr/^Search pattern not terminated at/, 312 { stderr => 1 }, 'open m test'); 313 314fresh_perl_is( 315 'sub f { open(my $fh, "xxx"); $fh = "f"; } f; f;print "ok"', 316 'ok', { stderr => 1 }, 317 '#29102: Crash on assignment to lexical filehandle'); 318