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 13plan tests => 121; 14 15my $Perl = which_perl(); 16 17my $afile = tempfile(); 18{ 19 unlink($afile) if -f $afile; 20 21 $! = 0; # the -f above will set $! if $afile doesn't exist. 22 ok( open(my $f,"+>$afile"), 'open(my $f, "+>...")' ); 23 24 binmode $f; 25 ok( -f $afile, ' its a file'); 26 ok( (print $f "SomeData\n"), ' we can print to it'); 27 is( tell($f), 9, ' tell()' ); 28 ok( seek($f,0,0), ' seek set' ); 29 30 $b = <$f>; 31 is( $b, "SomeData\n", ' readline' ); 32 ok( -f $f, ' still a file' ); 33 34 eval { die "Message" }; 35 like( $@, qr/<\$f> line 1/, ' die message correct' ); 36 37 ok( close($f), ' close()' ); 38 ok( unlink($afile), ' unlink()' ); 39} 40 41{ 42 ok( open(my $f,'>', $afile), "open(my \$f, '>', $afile)" ); 43 ok( (print $f "a row\n"), ' print'); 44 ok( close($f), ' close' ); 45 ok( -s $afile < 10, ' -s' ); 46} 47 48{ 49 ok( open(my $f,'>>', $afile), "open(my \$f, '>>', $afile)" ); 50 ok( (print $f "a row\n"), ' print' ); 51 ok( close($f), ' close' ); 52 ok( -s $afile > 10, ' -s' ); 53} 54 55{ 56 ok( open(my $f, '<', $afile), "open(my \$f, '<', $afile)" ); 57 my @rows = <$f>; 58 is( scalar @rows, 2, ' readline, list context' ); 59 is( $rows[0], "a row\n", ' first line read' ); 60 is( $rows[1], "a row\n", ' second line' ); 61 ok( close($f), ' close' ); 62} 63 64{ 65 ok( -s $afile < 20, '-s' ); 66 67 ok( open(my $f, '+<', $afile), 'open +<' ); 68 my @rows = <$f>; 69 is( scalar @rows, 2, ' readline, list context' ); 70 ok( seek($f, 0, 1), ' seek cur' ); 71 ok( (print $f "yet another row\n"), ' print' ); 72 ok( close($f), ' close' ); 73 ok( -s $afile > 20, ' -s' ); 74 75 unlink($afile); 76} 77{ 78 ok( open(my $f, '-|', <<EOC), 'open -|' ); 79 $Perl -e "print qq(a row\\n); print qq(another row\\n)" 80EOC 81 82 my @rows = <$f>; 83 is( scalar @rows, 2, ' readline, list context' ); 84 ok( close($f), ' close' ); 85} 86{ 87 ok( open(my $f, '|-', <<EOC), 'open |-' ); 88 $Perl -pe "s/^not //" 89EOC 90 91 my @rows = <$f>; 92 my $test = curr_test; 93 print $f "not ok $test - piped in\n"; 94 next_test; 95 96 $test = curr_test; 97 print $f "not ok $test - piped in\n"; 98 next_test; 99 ok( close($f), ' close' ); 100 sleep 1; 101 pass('flushing'); 102} 103 104 105ok( !eval { open my $f, '<&', $afile; 1; }, '<& on a non-filehandle' ); 106like( $@, qr/Bad filehandle:\s+$afile/, ' right error' ); 107 108ok( !eval { *some_glob = 1; open my $f, '<&', *some_glob; 1; }, '<& on a non-filehandle glob' ); 109like( $@, qr/Bad filehandle:\s+some_glob/, ' right error' ); 110 111{ 112 use utf8; 113 use open qw( :utf8 :std ); 114 ok( !eval { use utf8; *ǡfilḛ = 1; open my $f, '<&', *ǡfilḛ; 1; }, '<& on a non-filehandle glob' ); 115 like( $@, qr/Bad filehandle:\s+ǡfilḛ/u, ' right error' ); 116} 117 118# local $file tests 119{ 120 unlink($afile) if -f $afile; 121 122 ok( open(local $f,"+>$afile"), 'open local $f, "+>", ...' ); 123 binmode $f; 124 125 ok( -f $afile, ' -f' ); 126 ok( (print $f "SomeData\n"), ' print' ); 127 is( tell($f), 9, ' tell' ); 128 ok( seek($f,0,0), ' seek set' ); 129 130 $b = <$f>; 131 is( $b, "SomeData\n", ' readline' ); 132 ok( -f $f, ' still a file' ); 133 134 eval { die "Message" }; 135 like( $@, qr/<\$f> line 1/, ' proper die message' ); 136 ok( close($f), ' close' ); 137 138 unlink($afile); 139} 140 141{ 142 ok( open(local $f,'>', $afile), 'open local $f, ">", ...' ); 143 ok( (print $f "a row\n"), ' print'); 144 ok( close($f), ' close'); 145 ok( -s $afile < 10, ' -s' ); 146} 147 148{ 149 ok( open(local $f,'>>', $afile), 'open local $f, ">>", ...' ); 150 ok( (print $f "a row\n"), ' print'); 151 ok( close($f), ' close'); 152 ok( -s $afile > 10, ' -s' ); 153} 154 155{ 156 ok( open(local $f, '<', $afile), 'open local $f, "<", ...' ); 157 my @rows = <$f>; 158 is( scalar @rows, 2, ' readline list context' ); 159 ok( close($f), ' close' ); 160} 161 162ok( -s $afile < 20, ' -s' ); 163 164{ 165 ok( open(local $f, '+<', $afile), 'open local $f, "+<", ...' ); 166 my @rows = <$f>; 167 is( scalar @rows, 2, ' readline list context' ); 168 ok( seek($f, 0, 1), ' seek cur' ); 169 ok( (print $f "yet another row\n"), ' print' ); 170 ok( close($f), ' close' ); 171 ok( -s $afile > 20, ' -s' ); 172 173 unlink($afile); 174} 175 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 186{ 187 ok( open(local $f, '|-', <<EOC), 'open local $f, "|-", ...' ); 188 $Perl -pe "s/^not //" 189EOC 190 191 my @rows = <$f>; 192 my $test = curr_test; 193 print $f "not ok $test - piping\n"; 194 next_test; 195 196 $test = curr_test; 197 print $f "not ok $test - piping\n"; 198 next_test; 199 ok( close($f), ' close' ); 200 sleep 1; 201 pass("Flush"); 202} 203 204 205ok( !eval { open local $f, '<&', $afile; 1 }, 'local <& on non-filehandle'); 206like( $@, qr/Bad filehandle:\s+$afile/, ' right error' ); 207 208{ 209 local *F; 210 for (1..2) { 211 ok( open(F, qq{$Perl -le "print 'ok'"|}), 'open to pipe' ); 212 is(scalar <F>, "ok\n", ' readline'); 213 ok( close F, ' close' ); 214 } 215 216 for (1..2) { 217 ok( open(F, "-|", qq{$Perl -le "print 'ok'"}), 'open -|'); 218 is( scalar <F>, "ok\n", ' readline'); 219 ok( close F, ' close' ); 220 } 221} 222 223 224# other dupping techniques 225{ 226 ok( open(my $stdout, ">&", \*STDOUT), 'dup \*STDOUT into lexical fh'); 227 ok( open(STDOUT, ">&", $stdout), 'restore dupped STDOUT from lexical fh'); 228 229 { 230 use strict; # the below should not warn 231 ok( open(my $stdout, ">&", STDOUT), 'dup STDOUT into lexical fh'); 232 } 233 234 # used to try to open a file [perl #17830] 235 ok( open(my $stdin, "<&", fileno STDIN), 'dup fileno(STDIN) into lexical fh') or _diag $!; 236 237 fileno(STDIN) =~ /(.)/; 238 ok open($stdin, "<&", $1), 'open ... "<&", $magical_fileno', 239 || _diag $!; 240} 241 242SKIP: { 243 skip "This perl uses perlio", 1 if $Config{useperlio}; 244 skip_if_miniperl("miniperl can't rely on loading %Errno", 1); 245 # Force the reference to %! to be run time by writing ! as {"!"} 246 skip "This system doesn't understand EINVAL", 1 247 unless exists ${"!"}{EINVAL}; 248 249 no warnings 'io'; 250 ok(!open(F,'>',\my $s) && ${"!"}{EINVAL}, 'open(reference) raises EINVAL'); 251} 252 253{ 254 ok( !eval { open F, "BAR", "QUUX" }, 'Unknown open() mode' ); 255 like( $@, qr/\QUnknown open() mode 'BAR'/, ' right error' ); 256} 257 258{ 259 local $SIG{__WARN__} = sub { $@ = shift }; 260 261 sub gimme { 262 my $tmphandle = shift; 263 my $line = scalar <$tmphandle>; 264 warn "gimme"; 265 return $line; 266 } 267 268 open($fh0[0], "TEST"); 269 gimme($fh0[0]); 270 like($@, qr/<\$fh0\[...\]> line 1\./, "autoviv fh package aelem"); 271 272 open($fh1{k}, "TEST"); 273 gimme($fh1{k}); 274 like($@, qr/<\$fh1\{...}> line 1\./, "autoviv fh package helem"); 275 276 my @fh2; 277 open($fh2[0], "TEST"); 278 gimme($fh2[0]); 279 like($@, qr/<\$fh2\[...\]> line 1\./, "autoviv fh lexical aelem"); 280 281 my %fh3; 282 open($fh3{k}, "TEST"); 283 gimme($fh3{k}); 284 like($@, qr/<\$fh3\{...}> line 1\./, "autoviv fh lexical helem"); 285 286 local $/ = *F; # used to cause an assertion failure 287 gimme($fh3{k}); 288 like($@, qr/<\$fh3\{...}> chunk 2\./, 289 '<...> line 1 when $/ is set to a glob'); 290} 291 292SKIP: { 293 skip("These tests use perlio", 5) unless $Config{useperlio}; 294 my $w; 295 use warnings 'layer'; 296 local $SIG{__WARN__} = sub { $w = shift }; 297 298 eval { open(F, ">>>", $afile) }; 299 like($w, qr/Invalid separator character '>' in PerlIO layer spec/, 300 "bad open (>>>) warning"); 301 like($@, qr/Unknown open\(\) mode '>>>'/, 302 "bad open (>>>) failure"); 303 304 eval { open(F, ">:u", $afile ) }; 305 like($w, qr/Unknown PerlIO layer "u"/, 306 'bad layer ">:u" warning'); 307 eval { open(F, "<:u", $afile ) }; 308 like($w, qr/Unknown PerlIO layer "u"/, 309 'bad layer "<:u" warning'); 310 eval { open(F, ":c", $afile ) }; 311 like($@, qr/Unknown open\(\) mode ':c'/, 312 'bad layer ":c" failure'); 313} 314 315# [perl #28986] "open m" crashes Perl 316 317fresh_perl_like('open m', qr/^Search pattern not terminated at/, 318 { stderr => 1 }, 'open m test'); 319 320fresh_perl_is( 321 'sub f { open(my $fh, "xxx"); $fh = "f"; } f; f;print "ok"', 322 'ok', { stderr => 1 }, 323 '#29102: Crash on assignment to lexical filehandle'); 324 325# [perl #31767] Using $1 as a filehandle via open $1, "file" doesn't raise 326# an exception 327 328eval { open $99, "foo" }; 329like($@, qr/Modification of a read-only value attempted/, "readonly fh"); 330# But we do not want that exception applying to close(), since it does not 331# modify the fh. 332eval { 333 no warnings "uninitialized"; 334 # make sure $+ is undefined 335 "a" =~ /(b)?/; 336 close $+ 337}; 338is($@, '', 'no "Modification of a read-only value" when closing'); 339 340# [perl#73626] mg_get wasn't run on the pipe arg 341 342{ 343 package p73626; 344 sub TIESCALAR { bless {} } 345 sub FETCH { "$Perl -e 1"} 346 347 tie my $p, 'p73626'; 348 349 package main; 350 351 ok( open(my $f, '-|', $p), 'open -| magic'); 352} 353 354# [perl #77492] Crash when stringifying a glob, a reference to which has 355# been opened and written to. 356fresh_perl_is( 357 ' 358 open my $fh, ">", \*STDOUT; 359 print $fh "hello"; 360 "".*STDOUT; 361 print "ok"; 362 close $fh; 363 unlink \*STDOUT; 364 ', 365 'ok', { stderr => 1 }, 366 '[perl #77492]: open $fh, ">", \*glob causes SEGV'); 367 368# [perl #77684] Opening a reference to a glob copy. 369SKIP: { 370 skip_if_miniperl("no dynamic loading on miniperl, so can't load PerlIO::scalar", 1); 371 my $var = *STDOUT; 372 open my $fh, ">", \$var; 373 print $fh "hello"; 374 is $var, "hello", '[perl #77684]: open $fh, ">", \$glob_copy' 375 # when this fails, it leaves an extra file: 376 or unlink \*STDOUT; 377} 378 379# check that we can call methods on filehandles auto-magically 380# and have IO::File loaded for us 381SKIP: { 382 skip_if_miniperl("no dynamic loading on miniperl, so can't load IO::File", 3); 383 is( $INC{'IO/File.pm'}, undef, "IO::File not loaded" ); 384 my $var = ""; 385 open my $fh, ">", \$var; 386 ok( eval { $fh->autoflush(1); 1 }, '$fh->autoflush(1) lives' ); 387 ok( $INC{'IO/File.pm'}, "IO::File now loaded" ); 388} 389