diff options
Diffstat (limited to 'ext/PerlIO/scalar/t/scalar.t')
| -rw-r--r-- | ext/PerlIO/scalar/t/scalar.t | 233 |
1 files changed, 233 insertions, 0 deletions
diff --git a/ext/PerlIO/scalar/t/scalar.t b/ext/PerlIO/scalar/t/scalar.t new file mode 100644 index 0000000000..393ce0d375 --- /dev/null +++ b/ext/PerlIO/scalar/t/scalar.t @@ -0,0 +1,233 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + unless (find PerlIO::Layer 'perlio') { + print "1..0 # Skip: not perlio\n"; + exit 0; + } + require Config; + if (($Config::Config{'extensions'} !~ m!\bPerlIO/scalar\b!) ){ + print "1..0 # Skip -- Perl configured without PerlIO::scalar module\n"; + exit 0; + } +} + +use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); # Not 0, 1, 2 everywhere. + +$| = 1; + +use Test::More tests => 55; + +my $fh; +my $var = "aaa\n"; +ok(open($fh,"+<",\$var)); + +is(<$fh>, $var); + +ok(eof($fh)); + +ok(seek($fh,0,SEEK_SET)); +ok(!eof($fh)); + +ok(print $fh "bbb\n"); +is($var, "bbb\n"); +$var = "foo\nbar\n"; +ok(seek($fh,0,SEEK_SET)); +ok(!eof($fh)); +is(<$fh>, "foo\n"); +ok(close $fh, $!); + +# Test that semantics are similar to normal file-based I/O +# Check that ">" clobbers the scalar +$var = "Something"; +open $fh, ">", \$var; +is($var, ""); +# Check that file offset set to beginning of scalar +my $off = tell($fh); +is($off, 0); +# Check that writes go where they should and update the offset +$var = "Something"; +print $fh "Brea"; +$off = tell($fh); +is($off, 4); +is($var, "Breathing"); +close $fh; + +# Check that ">>" appends to the scalar +$var = "Something "; +open $fh, ">>", \$var; +$off = tell($fh); +is($off, 10); +is($var, "Something "); +# Check that further writes go to the very end of the scalar +$var .= "else "; +is($var, "Something else "); + +$off = tell($fh); +is($off, 10); + +print $fh "is here"; +is($var, "Something else is here"); +close $fh; + +# Check that updates to the scalar from elsewhere do not +# cause problems +$var = "line one\nline two\line three\n"; +open $fh, "<", \$var; +while (<$fh>) { + $var = "foo"; +} +close $fh; +is($var, "foo"); + +# Check that dup'ing the handle works + +$var = ''; +open $fh, "+>", \$var; +print $fh "xxx\n"; +open $dup,'+<&',$fh; +print $dup "yyy\n"; +seek($dup,0,SEEK_SET); +is(<$dup>, "xxx\n"); +is(<$dup>, "yyy\n"); +close($fh); +close($dup); + +open $fh, '<', \42; +is(<$fh>, "42", "reading from non-string scalars"); +close $fh; + +{ package P; sub TIESCALAR {bless{}} sub FETCH { "shazam" } } +tie $p, P; open $fh, '<', \$p; +is(<$fh>, "shazam", "reading from magic scalars"); + +{ + use warnings; + my $warn = 0; + local $SIG{__WARN__} = sub { $warn++ }; + open my $fh, '>', \my $scalar; + print $fh "foo"; + close $fh; + is($warn, 0, "no warnings when writing to an undefined scalar"); +} + +{ + use warnings; + my $warn = 0; + local $SIG{__WARN__} = sub { $warn++ }; + for (1..2) { + open my $fh, '>', \my $scalar; + close $fh; + } + is($warn, 0, "no warnings when reusing a lexical"); +} + +{ + use warnings; + my $warn = 0; + local $SIG{__WARN__} = sub { $warn++ }; + + my $fetch = 0; + { + package MgUndef; + sub TIESCALAR { bless [] } + sub FETCH { $fetch++; return undef } + } + tie my $scalar, MgUndef; + + open my $fh, '<', \$scalar; + close $fh; + is($warn, 0, "no warnings reading a magical undef scalar"); + is($fetch, 1, "FETCH only called once"); +} + +{ + use warnings; + my $warn = 0; + local $SIG{__WARN__} = sub { $warn++ }; + my $scalar = 3; + undef $scalar; + open my $fh, '<', \$scalar; + close $fh; + is($warn, 0, "no warnings reading an undef, allocated scalar"); +} + +my $data = "a non-empty PV"; +$data = undef; +open(MEM, '<', \$data) or die "Fail: $!\n"; +my $x = join '', <MEM>; +is($x, ''); + +{ + # [perl #35929] verify that works with $/ (i.e. test PerlIOScalar_unread) + my $s = <<'EOF'; +line A +line B +a third line +EOF + open(F, '<', \$s) or die "Could not open string as a file"; + local $/ = ""; + my $ln = <F>; + close F; + is($ln, $s, "[perl #35929]"); +} + +# [perl #40267] PerlIO::scalar doesn't respect readonly-ness +{ + ok(!(defined open(F, '>', \undef)), "[perl #40267] - $!"); + close F; + + my $ro = \43; + ok(!(defined open(F, '>', $ro)), $!); + close F; + # but we can read from it + ok(open(F, '<', $ro), $!); + is(<F>, 43); + close F; +} + +{ + # Check that we zero fill when needed when seeking, + # and that seeking negative off the string does not do bad things. + + my $foo; + + ok(open(F, '>', \$foo)); + + # Seeking forward should zero fill. + + ok(seek(F, 50, SEEK_SET)); + print F "x"; + is(length($foo), 51); + like($foo, qr/^\0{50}x$/); + + is(tell(F), 51); + ok(seek(F, 0, SEEK_SET)); + is(length($foo), 51); + + # Seeking forward again should zero fill but only the new bytes. + + ok(seek(F, 100, SEEK_SET)); + print F "y"; + is(length($foo), 101); + like($foo, qr/^\0{50}x\0{49}y$/); + is(tell(F), 101); + + # Seeking back and writing should not zero fill. + + ok(seek(F, 75, SEEK_SET)); + print F "z"; + is(length($foo), 101); + like($foo, qr/^\0{50}x\0{24}z\0{24}y$/); + is(tell(F), 76); + + # Seeking negative should not do funny business. + + ok(!seek(F, -50, SEEK_SET), $!); + ok(seek(F, 0, SEEK_SET)); + ok(!seek(F, -50, SEEK_CUR), $!); + ok(!seek(F, -150, SEEK_END), $!); +} + |