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