}
}
+use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); # Not 0, 1, 2 everywhere.
+
$| = 1;
-print "1..30\n";
+
+use Test::More tests => 51;
my $fh;
-my $var = "ok 2\n";
-open($fh,"+<",\$var) or print "not ";
-print "ok 1\n";
-print <$fh>;
-print "not " unless eof($fh);
-print "ok 3\n";
-seek($fh,0,0) or print "not ";
-print "not " if eof($fh);
-print "ok 4\n";
-print "ok 5\n";
-print $fh "ok 7\n" or print "not ";
-print "ok 6\n";
-print $var;
+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";
-seek($fh,0,0) or print "not ";
-print "not " if eof($fh);
-print "ok 8\n";
-print "not " unless <$fh> eq "foo\n";
-print "ok 9\n";
-my $rv = close $fh;
-if (!$rv) {
- print "# Close on scalar failed: $!\n";
- print "not ";
-}
-print "ok 10\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;
-print "# Got [$var], expect []\n";
-print "not " unless $var eq "";
-print "ok 11\n";
+is($var, "");
# Check that file offset set to beginning of scalar
my $off = tell($fh);
-print "# Got $off, expect 0\n";
-print "not " unless $off == 0;
-print "ok 12\n";
+is($off, 0);
# Check that writes go where they should and update the offset
$var = "Something";
print $fh "Brea";
$off = tell($fh);
-print "# Got $off, expect 4\n";
-print "not " unless $off == 4;
-print "ok 13\n";
-print "# Got [$var], expect [Breathing]\n";
-print "not " unless $var eq "Breathing";
-print "ok 14\n";
+is($off, 4);
+is($var, "Breathing");
close $fh;
# Check that ">>" appends to the scalar
$var = "Something ";
open $fh, ">>", \$var;
$off = tell($fh);
-print "# Got $off, expect 10\n";
-print "not " unless $off == 10;
-print "ok 15\n";
-print "# Got [$var], expect [Something ]\n";
-print "not " unless $var eq "Something ";
-print "ok 16\n";
+is($off, 10);
+is($var, "Something ");
# Check that further writes go to the very end of the scalar
$var .= "else ";
-print "# Got [$var], expect [Something else ]\n";
-print "not " unless $var eq "Something else ";
-print "ok 17\n";
+is($var, "Something else ");
+
$off = tell($fh);
-print "# Got $off, expect 10\n";
-print "not " unless $off == 10;
-print "ok 18\n";
+is($off, 10);
+
print $fh "is here";
-print "# Got [$var], expect [Something else is here]\n";
-print "not " unless $var eq "Something else is here";
-print "ok 19\n";
+is($var, "Something else is here");
close $fh;
# Check that updates to the scalar from elsewhere do not
$var = "foo";
}
close $fh;
-print "# Got [$var], expect [foo]\n";
-print "not " unless $var eq "foo";
-print "ok 20\n";
+is($var, "foo");
# Check that dup'ing the handle works
$var = '';
-
open $fh, "+>", \$var;
-print $fh "ok 21\n";
+print $fh "xxx\n";
open $dup,'+<&',$fh;
-print $dup "ok 22\n";
-seek($dup,0,0);
-while (<$dup>) {
- print;
-}
+print $dup "yyy\n";
+seek($dup,0,SEEK_SET);
+is(<$dup>, "xxx\n");
+is(<$dup>, "yyy\n");
close($fh);
close($dup);
-# Check reading from non-string scalars
-
open $fh, '<', \42;
-print <$fh> eq "42" ? "ok 23\n" : "not ok 23\n";
+is(<$fh>, "42", "reading from non-string scalars");
close $fh;
-# reading from magic scalars
-
-{ package P; sub TIESCALAR {bless{}} sub FETCH {"ok 24\n"} }
+{ package P; sub TIESCALAR {bless{}} sub FETCH { "shazam" } }
tie $p, P; open $fh, '<', \$p;
-print <$fh>;
-
-# don't warn when writing to an undefined scalar
+is(<$fh>, "shazam", "reading from magic scalars");
{
use warnings;
- my $ok = 1;
- local $SIG{__WARN__} = sub { $ok = 0; };
+ my $warn = 0;
+ local $SIG{__WARN__} = sub { $warn++ };
open my $fh, '>', \my $scalar;
print $fh "foo";
close $fh;
- print $ok ? "ok 25\n" : "not ok 25\n";
+ is($warn, 0, "no warnings when writing to an undefined scalar");
}
my $data = "a non-empty PV";
$data = undef;
open(MEM, '<', \$data) or die "Fail: $!\n";
my $x = join '', <MEM>;
-print $x eq '' ? "ok 26\n" : "not ok 26\n";
+is($x, '');
{
# [perl #35929] verify that works with $/ (i.e. test PerlIOScalar_unread)
local $/ = "";
my $ln = <F>;
close F;
- print $ln eq $s ? "ok 27\n" : "not ok 27\n";
+ is($ln, $s, "[perl #35929]");
}
# [perl #40267] PerlIO::scalar doesn't respect readonly-ness
{
- if (open(F, '>', \undef)) {
- print "not ok 28\n";
- }
- else {
- print "ok 28 - \$! is $!\n";
- }
+ ok(!(defined open(F, '>', \undef)), "[perl #40267] - $!");
close F;
+
my $ro = \43;
- if (open(F, '>', $ro)) {
- print "not ok 29\n";
- }
- else {
- print "ok 29 - \$! is $!\n";
- }
+ ok(!(defined open(F, '>', $ro)), $!);
close F;
# but we can read from it
- if (open(F, '<', $ro)) {
- print "ok 30\n";
- }
- else {
- print "not ok 30 - \$! is $!\n";
- }
+ 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), $!);
+}
+
projects / p5sagit/p5-mst-13.2.git / commitdiff