open.t revision 1.11
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 => 108; 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 108 109# local $file tests 110{ 111 unlink($afile) if -f $afile; 112 113 ok( open(local $f,"+>$afile"), 'open local $f, "+>", ...' ); 114 binmode $f; 115 116 ok( -f $afile, ' -f' ); 117 ok( (print $f "SomeData\n"), ' print' ); 118 is( tell($f), 9, ' tell' ); 119 ok( seek($f,0,0), ' seek set' ); 120 121 $b = <$f>; 122 is( $b, "SomeData\n", ' readline' ); 123 ok( -f $f, ' still a file' ); 124 125 eval { die "Message" }; 126 like( $@, qr/<\$f> line 1/, ' proper die message' ); 127 ok( close($f), ' close' ); 128 129 unlink($afile); 130} 131 132{ 133 ok( open(local $f,'>', $afile), 'open local $f, ">", ...' ); 134 ok( (print $f "a row\n"), ' print'); 135 ok( close($f), ' close'); 136 ok( -s $afile < 10, ' -s' ); 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 my @rows = <$f>; 149 is( scalar @rows, 2, ' readline list context' ); 150 ok( close($f), ' close' ); 151} 152 153ok( -s $afile < 20, ' -s' ); 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( seek($f, 0, 1), ' seek cur' ); 160 ok( (print $f "yet another row\n"), ' print' ); 161 ok( close($f), ' close' ); 162 ok( -s $afile > 20, ' -s' ); 163 164 unlink($afile); 165} 166 167{ 168 ok( open(local $f, '-|', <<EOC), 'open local $f, "-|", ...' ); 169 $Perl -e "print qq(a row\\n); print qq(another row\\n)" 170EOC 171 my @rows = <$f>; 172 173 is( scalar @rows, 2, ' readline list context' ); 174 ok( close($f), ' close' ); 175} 176 177{ 178 ok( open(local $f, '|-', <<EOC), 'open local $f, "|-", ...' ); 179 $Perl -pe "s/^not //" 180EOC 181 182 my @rows = <$f>; 183 my $test = curr_test; 184 print $f "not ok $test - piping\n"; 185 next_test; 186 187 $test = curr_test; 188 print $f "not ok $test - piping\n"; 189 next_test; 190 ok( close($f), ' close' ); 191 sleep 1; 192 pass("Flush"); 193} 194 195 196ok( !eval { open local $f, '<&', $afile; 1 }, 'local <& on non-filehandle'); 197like( $@, qr/Bad filehandle:\s+$afile/, ' right error' ); 198 199{ 200 local *F; 201 for (1..2) { 202 ok( open(F, qq{$Perl -le "print 'ok'"|}), 'open to pipe' ); 203 is(scalar <F>, "ok\n", ' readline'); 204 ok( close F, ' close' ); 205 } 206 207 for (1..2) { 208 ok( open(F, "-|", qq{$Perl -le "print 'ok'"}), 'open -|'); 209 is( scalar <F>, "ok\n", ' readline'); 210 ok( close F, ' close' ); 211 } 212} 213 214 215# other dupping techniques 216{ 217 ok( open(my $stdout, ">&", \*STDOUT), 'dup \*STDOUT into lexical fh'); 218 ok( open(STDOUT, ">&", $stdout), 'restore dupped STDOUT from lexical fh'); 219 220 { 221 use strict; # the below should not warn 222 ok( open(my $stdout, ">&", STDOUT), 'dup STDOUT into lexical fh'); 223 } 224 225 # used to try to open a file [perl #17830] 226 ok( open(my $stdin, "<&", fileno STDIN), 'dup fileno(STDIN) into lexical fh') or _diag $!; 227} 228 229SKIP: { 230 skip "This perl uses perlio", 1 if $Config{useperlio}; 231 skip "miniperl cannot be relied on to load %Errno" 232 if $ENV{PERL_CORE_MINITEST}; 233 # Force the reference to %! to be run time by writing ! as {"!"} 234 skip "This system doesn't understand EINVAL", 1 235 unless exists ${"!"}{EINVAL}; 236 237 no warnings 'io'; 238 ok(!open(F,'>',\my $s) && ${"!"}{EINVAL}, 'open(reference) raises EINVAL'); 239} 240 241{ 242 ok( !eval { open F, "BAR", "QUUX" }, 'Unknown open() mode' ); 243 like( $@, qr/\QUnknown open() mode 'BAR'/, ' right error' ); 244} 245 246{ 247 local $SIG{__WARN__} = sub { $@ = shift }; 248 249 sub gimme { 250 my $tmphandle = shift; 251 my $line = scalar <$tmphandle>; 252 warn "gimme"; 253 return $line; 254 } 255 256 open($fh0[0], "TEST"); 257 gimme($fh0[0]); 258 like($@, qr/<\$fh0\[...\]> line 1\./, "autoviv fh package aelem"); 259 260 open($fh1{k}, "TEST"); 261 gimme($fh1{k}); 262 like($@, qr/<\$fh1{...}> line 1\./, "autoviv fh package helem"); 263 264 my @fh2; 265 open($fh2[0], "TEST"); 266 gimme($fh2[0]); 267 like($@, qr/<\$fh2\[...\]> line 1\./, "autoviv fh lexical aelem"); 268 269 my %fh3; 270 open($fh3{k}, "TEST"); 271 gimme($fh3{k}); 272 like($@, qr/<\$fh3{...}> line 1\./, "autoviv fh lexical helem"); 273} 274 275SKIP: { 276 skip("These tests use perlio", 5) unless $Config{useperlio}; 277 my $w; 278 use warnings 'layer'; 279 local $SIG{__WARN__} = sub { $w = shift }; 280 281 eval { open(F, ">>>", $afile) }; 282 like($w, qr/Invalid separator character '>' in PerlIO layer spec/, 283 "bad open (>>>) warning"); 284 like($@, qr/Unknown open\(\) mode '>>>'/, 285 "bad open (>>>) failure"); 286 287 eval { open(F, ">:u", $afile ) }; 288 like($w, qr/Unknown PerlIO layer "u"/, 289 'bad layer ">:u" warning'); 290 eval { open(F, "<:u", $afile ) }; 291 like($w, qr/Unknown PerlIO layer "u"/, 292 'bad layer "<:u" warning'); 293 eval { open(F, ":c", $afile ) }; 294 like($@, qr/Unknown open\(\) mode ':c'/, 295 'bad layer ":c" failure'); 296} 297 298# [perl #28986] "open m" crashes Perl 299 300fresh_perl_like('open m', qr/^Search pattern not terminated at/, 301 { stderr => 1 }, 'open m test'); 302 303fresh_perl_is( 304 'sub f { open(my $fh, "xxx"); $fh = "f"; } f; f;print "ok"', 305 'ok', { stderr => 1 }, 306 '#29102: Crash on assignment to lexical filehandle'); 307 308# [perl #31767] Using $1 as a filehandle via open $1, "file" doesn't raise 309# an exception 310 311eval { open $99, "foo" }; 312like($@, qr/Modification of a read-only value attempted/, "readonly fh"); 313