1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require './test.pl'; 6 set_up_inc('../lib'); 7 skip_all('Can\'t run under miniperl') if is_miniperl(); 8} 9 10use strict; 11 12use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); # Not 0, 1, 2 everywhere. 13use Errno qw(EACCES); 14 15plan(128); 16 17my $fh; 18my $var = "aaa\n"; 19ok(open($fh,"+<",\$var)); 20 21is(<$fh>, $var); 22 23ok(eof($fh)); 24 25ok(seek($fh,0,SEEK_SET)); 26ok(!eof($fh)); 27 28ok(print $fh "bbb\n"); 29is($var, "bbb\n"); 30$var = "foo\nbar\n"; 31ok(seek($fh,0,SEEK_SET)); 32ok(!eof($fh)); 33is(<$fh>, "foo\n"); 34ok(close $fh, $!); 35 36# Test that semantics are similar to normal file-based I/O 37# Check that ">" clobbers the scalar 38$var = "Something"; 39open $fh, ">", \$var; 40is($var, ""); 41# Check that file offset set to beginning of scalar 42my $off = tell($fh); 43is($off, 0); 44# Check that writes go where they should and update the offset 45$var = "Something"; 46print $fh "Brea"; 47$off = tell($fh); 48is($off, 4); 49is($var, "Breathing"); 50close $fh; 51 52# Check that ">>" appends to the scalar 53$var = "Something "; 54open $fh, ">>", \$var; 55$off = tell($fh); 56is($off, 10); 57is($var, "Something "); 58# Check that further writes go to the very end of the scalar 59$var .= "else "; 60is($var, "Something else "); 61 62$off = tell($fh); 63is($off, 10); 64 65print $fh "is here"; 66is($var, "Something else is here"); 67close $fh; 68 69# Check that updates to the scalar from elsewhere do not 70# cause problems 71$var = "line one\nline two\line three\n"; 72open $fh, "<", \$var; 73while (<$fh>) { 74 $var = "foo"; 75} 76close $fh; 77is($var, "foo"); 78 79# Check that dup'ing the handle works 80 81$var = ''; 82open $fh, "+>", \$var; 83print $fh "xxx\n"; 84open my $dup,'+<&',$fh; 85print $dup "yyy\n"; 86seek($dup,0,SEEK_SET); 87is(<$dup>, "xxx\n"); 88is(<$dup>, "yyy\n"); 89close($fh); 90close($dup); 91 92open $fh, '<', \42; 93is(<$fh>, "42", "reading from non-string scalars"); 94close $fh; 95 96{ package P; sub TIESCALAR {bless{}} sub FETCH { "shazam" } sub STORE {} } 97tie my $p, 'P'; open $fh, '<', \$p; 98is(<$fh>, "shazam", "reading from magic scalars"); 99 100{ 101 use warnings; 102 my $warn = 0; 103 local $SIG{__WARN__} = sub { $warn++ }; 104 open my $fh, '>', \my $scalar; 105 print $fh "foo"; 106 close $fh; 107 is($warn, 0, "no warnings when writing to an undefined scalar"); 108 undef $scalar; 109 open $fh, '>>', \$scalar; 110 print $fh "oof"; 111 close $fh; 112 is($warn, 0, "no warnings when appending to an undefined scalar"); 113} 114 115{ 116 use warnings; 117 my $warn = 0; 118 local $SIG{__WARN__} = sub { $warn++ }; 119 for (1..2) { 120 open my $fh, '>', \my $scalar; 121 close $fh; 122 } 123 is($warn, 0, "no warnings when reusing a lexical"); 124} 125 126{ 127 use warnings; 128 my $warn = 0; 129 local $SIG{__WARN__} = sub { $warn++ }; 130 131 my $fetch = 0; 132 { 133 package MgUndef; 134 sub TIESCALAR { bless [] } 135 sub FETCH { $fetch++; return undef } 136 sub STORE {} 137 } 138 tie my $scalar, 'MgUndef'; 139 140 open my $fh, '<', \$scalar; 141 close $fh; 142 is($warn, 0, "no warnings reading a magical undef scalar"); 143 is($fetch, 1, "FETCH only called once"); 144} 145 146{ 147 use warnings; 148 my $warn = 0; 149 local $SIG{__WARN__} = sub { $warn++ }; 150 my $scalar = 3; 151 undef $scalar; 152 open my $fh, '<', \$scalar; 153 close $fh; 154 is($warn, 0, "no warnings reading an undef, allocated scalar"); 155} 156 157my $data = "a non-empty PV"; 158$data = undef; 159open(MEM, '<', \$data) or die "Fail: $!\n"; 160my $x = join '', <MEM>; 161is($x, ''); 162 163{ 164 # [perl #35929] verify that works with $/ (i.e. test PerlIOScalar_unread) 165 my $s = <<'EOF'; 166line A 167line B 168a third line 169EOF 170 open(F, '<', \$s) or die "Could not open string as a file"; 171 local $/ = ""; 172 my $ln = <F>; 173 close F; 174 is($ln, $s, "[perl #35929]"); 175} 176 177# [perl #40267] PerlIO::scalar doesn't respect readonly-ness 178{ 179 my $warn; 180 local $SIG{__WARN__} = sub { $warn = "@_" }; 181 ok(!(defined open(F, '>', \undef)), "[perl #40267] - $!"); 182 is($warn, undef, "no warning with warnings off"); 183 close F; 184 185 use warnings 'layer'; 186 undef $warn; 187 my $ro = \43; 188 ok(!(defined open(F, '>', $ro)), $!); 189 is($!+0, EACCES, "check we get a read-onlyish error code"); 190 like($warn, qr/Modification of a read-only value attempted/, 191 "check we did warn"); 192 close F; 193 # but we can read from it 194 ok(open(F, '<', $ro), $!); 195 is(<F>, 43); 196 close F; 197} 198 199{ 200 # Check that we zero fill when needed when seeking, 201 # and that seeking negative off the string does not do bad things. 202 203 my $foo; 204 205 ok(open(F, '>', \$foo)); 206 207 # Seeking forward should zero fill. 208 209 ok(seek(F, 50, SEEK_SET)); 210 print F "x"; 211 is(length($foo), 51); 212 like($foo, qr/^\0{50}x$/); 213 214 is(tell(F), 51); 215 ok(seek(F, 0, SEEK_SET)); 216 is(length($foo), 51); 217 218 # Seeking forward again should zero fill but only the new bytes. 219 220 ok(seek(F, 100, SEEK_SET)); 221 print F "y"; 222 is(length($foo), 101); 223 like($foo, qr/^\0{50}x\0{49}y$/); 224 is(tell(F), 101); 225 226 # Seeking back and writing should not zero fill. 227 228 ok(seek(F, 75, SEEK_SET)); 229 print F "z"; 230 is(length($foo), 101); 231 like($foo, qr/^\0{50}x\0{24}z\0{24}y$/); 232 is(tell(F), 76); 233 234 # Seeking negative should not do funny business. 235 236 ok(!seek(F, -50, SEEK_SET), $!); 237 ok(seek(F, 0, SEEK_SET)); 238 ok(!seek(F, -50, SEEK_CUR), $!); 239 ok(!seek(F, -150, SEEK_END), $!); 240} 241 242# RT #43789: should respect tied scalar 243 244{ 245 package TS; 246 my $s; 247 sub TIESCALAR { bless \my $x } 248 sub FETCH { $s .= ':F'; ${$_[0]} } 249 sub STORE { $s .= ":S($_[1])"; ${$_[0]} = $_[1] } 250 251 package main; 252 253 my $x; 254 $s = ''; 255 tie $x, 'TS'; 256 my $fh; 257 258 ok(open($fh, '>', \$x), 'open-write tied scalar'); 259 $s .= ':O'; 260 print($fh 'ABC'); 261 $s .= ':P'; 262 ok(seek($fh, 0, SEEK_SET)); 263 $s .= ':SK'; 264 print($fh 'DEF'); 265 $s .= ':P'; 266 ok(close($fh), 'close tied scalar - write'); 267 is($s, ':F:S():O:F:S(ABC):P:SK:F:S(DEF):P', 'tied actions - write'); 268 is($x, 'DEF', 'new value preserved'); 269 270 $x = 'GHI'; 271 $s = ''; 272 ok(open($fh, '+<', \$x), 'open-read tied scalar'); 273 $s .= ':O'; 274 my $buf; 275 is(read($fh,$buf,2), 2, 'read1'); 276 $s .= ':R'; 277 is($buf, 'GH', 'buf1'); 278 is(read($fh,$buf,2), 1, 'read2'); 279 $s .= ':R'; 280 is($buf, 'I', 'buf2'); 281 is(read($fh,$buf,2), 0, 'read3'); 282 $s .= ':R'; 283 is($buf, '', 'buf3'); 284 ok(close($fh), 'close tied scalar - read'); 285 is($s, ':F:S(GHI):O:F:R:F:R:F:R', 'tied actions - read'); 286} 287 288# [perl #78716] Seeking beyond the end of the string, then reading 289{ 290 my $str = '1234567890'; 291 open my $strIn, '<', \$str; 292 seek $strIn, 15, 1; 293 is read($strIn, my $buffer, 5), 0, 294 'seek beyond end end of string followed by read'; 295} 296 297# Writing to COW scalars and non-PVs 298{ 299 my $bovid = __PACKAGE__; 300 open my $handel, ">", \$bovid; 301 print $handel "the COW with the crumpled horn"; 302 is $bovid, "the COW with the crumpled horn", 'writing to COW scalars'; 303 304 package lrcg { use overload fallback => 1, '""'=>sub { 'chin' } } 305 seek $handel, 3, 0; 306 $bovid = bless [], lrcg::; 307 print $handel 'mney'; 308 is $bovid, 'chimney', 'writing to refs'; 309 310 seek $handel, 1, 0; 311 $bovid = 42; # still has a PV 312 print $handel 5; 313 is $bovid, 45, 'writing to numeric scalar'; 314 315 seek $handel, 1, 0; 316 undef $bovid; 317 $bovid = 42; # just IOK 318 print $handel 5; 319 is $bovid, 45, 'writing to numeric scalar'; 320} 321 322# [perl #92706] 323{ 324 open my $fh, "<", \(my $f=*f); seek $fh, 2,1; 325 pass 'seeking on a glob copy'; 326 open my $fh, "<", \(my $f=*f); seek $fh, -2,2; 327 pass 'seeking on a glob copy from the end'; 328} 329 330# [perl #108398] 331sub has_trailing_nul(\$) { 332 my ($ref) = @_; 333 my $sv = B::svref_2object($ref); 334 return undef if !$sv->isa('B::PV'); 335 336 my $cur = $sv->CUR; 337 my $len = $sv->LEN; 338 return 0 if $cur >= $len; 339 340 my $ptrlen = length(pack('P', '')); 341 my $ptrfmt 342 = $ptrlen == length(pack('J', 0)) ? 'J' 343 : $ptrlen == length(pack('I', 0)) ? 'I' 344 : die "Can't determine pointer format"; 345 346 my $pv_addr = unpack $ptrfmt, pack 'P', $$ref; 347 my $trailing = unpack 'P', pack $ptrfmt, $pv_addr+$cur; 348 return $trailing eq "\0"; 349} 350SKIP: { 351 if ($Config::Config{'extensions'} !~ m!\bB\b!) { 352 skip "no B", 4; 353 } 354 require B; 355 356 open my $fh, ">", \my $memfile or die $!; 357 358 print $fh "abc"; 359 ok has_trailing_nul $memfile, 360 'write appends trailing null when growing string'; 361 362 seek $fh, 0,SEEK_SET; 363 print $fh "abc"; 364 ok has_trailing_nul $memfile, 365 'write appends trailing null when not growing string'; 366 367 seek $fh, 200, SEEK_SET; 368 print $fh "abc"; 369 ok has_trailing_nul $memfile, 370 'write appends null when growing string after seek past end'; 371 372 open $fh, ">", \($memfile = "hello"); 373 ok has_trailing_nul $memfile, 374 'initial truncation in ">" mode provides trailing null'; 375} 376 377# [perl #112780] Cloning of in-memory handles 378SKIP: { 379 skip "no threads", 2 if !$Config::Config{useithreads}; 380 require threads; 381 my $str = ''; 382 open my $fh, ">", \$str; 383 $str = 'a'; 384 is scalar threads::async(sub { my $foo = $str; $foo })->join, "a", 385 'scalars behind in-memory handles are cloned properly'; 386 print $fh "a"; 387 is scalar threads::async(sub { print $fh "b"; $str })->join, "ab", 388 'printing to a cloned in-memory handle works'; 389} 390 391# [perl #113764] Duping via >&= (broken by the fix for #112870) 392{ 393 open FILE, '>', \my $content or die "Couldn't open scalar filehandle"; 394 open my $fh, ">&=FILE" or die "Couldn't open: $!"; 395 print $fh "Foo-Bar\n"; 396 close $fh; 397 close FILE; 398 is $content, "Foo-Bar\n", 'duping via >&='; 399} 400 401# [perl #109828] PerlIO::scalar does not handle UTF-8 402my $byte_warning = "Strings with code points over 0xFF may not be mapped into in-memory file handles\n"; 403{ 404 use Errno qw(EINVAL); 405 my @warnings; 406 local $SIG{__WARN__} = sub { push @warnings, "@_" }; 407 my $content = "12\x{101}"; 408 $! = 0; 409 ok(!open(my $fh, "<", \$content), "non-byte open should fail"); 410 is(0+$!, EINVAL, "check \$! is updated"); 411 is(@warnings, 0, "should be no warnings (yet)"); 412 use warnings "utf8"; 413 $! = 0; 414 ok(!open(my $fh, "<", \$content), "non byte open should fail (and warn)"); 415 is(0+$!, EINVAL, "check \$! is updated even when we warn"); 416 is(@warnings, 1, "should have warned"); 417 is($warnings[0], $byte_warning, "should have warned"); 418 419 @warnings = (); 420 $content = "12\xA1"; 421 utf8::upgrade($content); 422 ok(open(my $fh, "<", \$content), "open upgraded scalar"); 423 binmode $fh; 424 my $tmp; 425 is(read($fh, $tmp, 4), 3, "read should get the downgraded bytes"); 426 is($tmp, "12\xA1", "check we got the expected bytes"); 427 close $fh; 428 is(@warnings, 0, "should be no more warnings"); 429} 430{ # changes after open 431 my $content = "abc"; 432 ok(open(my $fh, "+<", \$content), "open a scalar"); 433 binmode $fh; 434 my $tmp; 435 is(read($fh, $tmp, 1), 1, "basic read"); 436 seek($fh, 1, SEEK_SET); 437 $content = "\xA1\xA2\xA3"; 438 utf8::upgrade($content); 439 is(read($fh, $tmp, 1), 1, "read from post-open upgraded scalar"); 440 is($tmp, "\xA2", "check we read the correct value"); 441 seek($fh, 1, SEEK_SET); 442 $content = "\x{101}\x{102}\x{103}"; 443 444 my @warnings; 445 local $SIG{__WARN__} = sub { push @warnings, "@_" }; 446 447 $! = 0; 448 is(read($fh, $tmp, 1), undef, "read from scalar with >0xff chars"); 449 is(0+$!, EINVAL, "check errno set correctly"); 450 is(@warnings, 0, "should be no warnings (yet)"); 451 use warnings "utf8"; 452 seek($fh, 1, SEEK_SET); 453 is(read($fh, $tmp, 1), undef, "read from scalar with >0xff chars"); 454 is(@warnings, 1, "check warnings"); 455 is($warnings[0], $byte_warning, "check warnings"); 456 457 select $fh; # make sure print fails rather tha buffers 458 $| = 1; 459 select STDERR; 460 no warnings "utf8"; 461 @warnings = (); 462 $content = "\xA1\xA2\xA3"; 463 utf8::upgrade($content); 464 seek($fh, 1, SEEK_SET); 465 ok((print $fh "A"), "print to an upgraded byte string"); 466 seek($fh, 1, SEEK_SET); 467 is($content, "\xA1A\xA3", "check result"); 468 469 $content = "\x{101}\x{102}\x{103}"; 470 $! = 0; 471 ok(!(print $fh "B"), "write to an non-downgradable SV"); 472 is(0+$!, EINVAL, "check errno set"); 473 474 is(@warnings, 0, "should be no warning"); 475 476 use warnings "utf8"; 477 ok(!(print $fh "B"), "write to an non-downgradable SV (and warn)"); 478 is(@warnings, 1, "check warnings"); 479 is($warnings[0], $byte_warning, "check warnings"); 480} 481 482# RT #119529: Reading refs should not loop 483 484{ 485 my $x = \42; 486 open my $fh, "<", \$x; 487 my $got = <$fh>; # this used to loop 488 like($got, qr/^SCALAR\(0x[0-9a-f]+\)$/, "ref to a ref"); 489 is ref $x, "SCALAR", "target scalar is still a reference"; 490} 491 492# Appending to refs 493{ 494 my $x = \42; 495 my $as_string = "$x"; 496 open my $refh, ">>", \$x; 497 is ref $x, "SCALAR", 'still a ref after opening for appending'; 498 print $refh "boo\n"; 499 is $x, $as_string."boo\n", 'string gets appended to ref'; 500} 501 502SKIP: 503{ # [perl #123443] 504 skip "Can't seek over 4GB with a small off_t", 4 505 if $Config::Config{lseeksize} < 8; 506 my $buf0 = "hello"; 507 open my $fh, "<", \$buf0 or die $!; 508 ok(seek($fh, 2**32, SEEK_SET), "seek to a large position"); 509 is(read($fh, my $tmp, 1), 0, "read from a large offset"); 510 is($tmp, "", "should have read nothing"); 511 ok(eof($fh), "fh should be eof"); 512} 513 514{ 515 my $buf0 = "hello"; 516 open my $fh, "<", \$buf0 or die $!; 517 ok(!seek($fh, -10, SEEK_CUR), "seek to negative position"); 518 is(tell($fh), 0, "shouldn't change the position"); 519} 520 521SKIP: 522{ # write() beyond SSize_t limit 523 skip "Can't overflow SSize_t with Off_t", 2 524 if $Config::Config{lseeksize} <= $Config::Config{sizesize}; 525 my $buf0 = "hello"; 526 open my $fh, "+<", \$buf0 or die $!; 527 ok(seek($fh, 2**32, SEEK_SET), "seek to a large position"); 528 select((select($fh), ++$|)[0]); 529 ok(!(print $fh "x"), "write to a large offset"); 530} 531