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