From: Jarkko Hietaniemi Date: Fri, 29 Sep 2006 17:41:28 +0000 (+0300) Subject: PerlIO::scalar (aka open(my $fh, >\$foo)): zero-filling seekand don't talk to negativ... X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=42bc49da149640802c6d82e088ba670810f22d2a;p=p5sagit%2Fp5-mst-13.2.git PerlIO::scalar (aka open(my $fh, >\$foo)): zero-filling seekand don't talk to negative strangers Message-ID: <451D3098.1000305@iki.fi> p4raw-id: //depot/perl@28903 --- diff --git a/ext/PerlIO/scalar/scalar.xs b/ext/PerlIO/scalar/scalar.xs index 50a718f..319c851 100644 --- a/ext/PerlIO/scalar/scalar.xs +++ b/ext/PerlIO/scalar/scalar.xs @@ -27,7 +27,7 @@ PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, if (SvREADONLY(SvRV(arg)) && mode && *mode != 'r') { if (ckWARN(WARN_LAYER)) Perl_warner(aTHX_ packWARN(WARN_LAYER), PL_no_modify); - errno = EINVAL; + SETERRNO(EINVAL, SS_IVCHAN); return -1; } s->var = SvREFCNT_inc(SvRV(arg)); @@ -83,20 +83,32 @@ IV PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence) { PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); + STRLEN oldcur = SvCUR(s->var); + STRLEN newlen; switch (whence) { - case 0: + case SEEK_SET: s->posn = offset; break; - case 1: + case SEEK_CUR: s->posn = offset + s->posn; break; - case 2: + case SEEK_END: s->posn = offset + SvCUR(s->var); break; } - if ((STRLEN) s->posn > SvCUR(s->var)) { - (void) SvGROW(s->var, (STRLEN) s->posn); + if (s->posn < 0) { + if (ckWARN(WARN_LAYER)) + Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string"); + SETERRNO(EINVAL, SS_IVCHAN); + return -1; } + newlen = (STRLEN) s->posn; + if (newlen > oldcur) { + (void) SvGROW(s->var, newlen); + Zero(SvPVX(s->var) + oldcur, newlen - oldcur, char); + /* No SvCUR_set(), though. This is just a seek, not a write. */ + } + SvPOK_on(s->var); return 0; } diff --git a/ext/PerlIO/t/scalar.t b/ext/PerlIO/t/scalar.t index 626fe4c..81c9277 100644 --- a/ext/PerlIO/t/scalar.t +++ b/ext/PerlIO/t/scalar.t @@ -14,83 +14,62 @@ BEGIN { } } +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 @@ -101,54 +80,44 @@ while (<$fh>) { $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 '', ; -print $x eq '' ? "ok 26\n" : "not ok 26\n"; +is($x, ''); { # [perl #35929] verify that works with $/ (i.e. test PerlIOScalar_unread) @@ -161,32 +130,63 @@ EOF local $/ = ""; my $ln = ; 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(, 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), $!); +} + diff --git a/pod/perldiag.pod b/pod/perldiag.pod index f3a5eed..d55ba22 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -2764,10 +2764,10 @@ which is odd, because hashes come in key/value pairs. =item Offset outside string -(F) You tried to do a read/write/send/recv operation with an offset -pointing outside the buffer. This is difficult to imagine. The sole -exception to this is that Cing past the buffer will extend -the buffer and zero pad the new area. +(F, W layer) You tried to do a read/write/send/recv/seek operation +with an offset pointing outside the buffer. This is difficult to +imagine. The sole exception to this is that Cing past the +buffer will extend the buffer and zero pad the new area. =item %s() on unopened %s