4 unless (find PerlIO::Layer 'perlio') {
5 print "1..0 # Skip: not perlio\n";
9 if (($Config::Config{'extensions'} !~ m!\bPerlIO/scalar\b!) ){
10 print "1..0 # Skip -- Perl configured without PerlIO::scalar module\n";
15 use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); # Not 0, 1, 2 everywhere.
19 use Test::More tests => 55;
23 ok(open($fh,"+<",\$var));
29 ok(seek($fh,0,SEEK_SET));
32 ok(print $fh "bbb\n");
35 ok(seek($fh,0,SEEK_SET));
40 # Test that semantics are similar to normal file-based I/O
41 # Check that ">" clobbers the scalar
45 # Check that file offset set to beginning of scalar
48 # Check that writes go where they should and update the offset
53 is($var, "Breathing");
56 # Check that ">>" appends to the scalar
58 open $fh, ">>", \$var;
61 is($var, "Something ");
62 # Check that further writes go to the very end of the scalar
64 is($var, "Something else ");
70 is($var, "Something else is here");
73 # Check that updates to the scalar from elsewhere do not
75 $var = "line one\nline two\line three\n";
83 # Check that dup'ing the handle works
86 open $fh, "+>", \$var;
90 seek($dup,0,SEEK_SET);
97 is(<$fh>, "42", "reading from non-string scalars");
100 { package P; sub TIESCALAR {bless{}} sub FETCH { "shazam" } }
101 tie $p, P; open $fh, '<', \$p;
102 is(<$fh>, "shazam", "reading from magic scalars");
107 local $SIG{__WARN__} = sub { $warn++ };
108 open my $fh, '>', \my $scalar;
111 is($warn, 0, "no warnings when writing to an undefined scalar");
117 local $SIG{__WARN__} = sub { $warn++ };
119 open my $fh, '>', \my $scalar;
122 is($warn, 0, "no warnings when reusing a lexical");
128 local $SIG{__WARN__} = sub { $warn++ };
133 sub TIESCALAR { bless [] }
134 sub FETCH { $fetch++; return undef }
136 tie my $scalar, MgUndef;
138 open my $fh, '<', \$scalar;
140 is($warn, 0, "no warnings reading a magical undef scalar");
141 is($fetch, 1, "FETCH only called once");
147 local $SIG{__WARN__} = sub { $warn++ };
150 open my $fh, '<', \$scalar;
152 is($warn, 0, "no warnings reading an undef, allocated scalar");
155 my $data = "a non-empty PV";
157 open(MEM, '<', \$data) or die "Fail: $!\n";
158 my $x = join '', <MEM>;
162 # [perl #35929] verify that works with $/ (i.e. test PerlIOScalar_unread)
168 open(F, '<', \$s) or die "Could not open string as a file";
172 is($ln, $s, "[perl #35929]");
175 # [perl #40267] PerlIO::scalar doesn't respect readonly-ness
177 ok(!(defined open(F, '>', \undef)), "[perl #40267] - $!");
181 ok(!(defined open(F, '>', $ro)), $!);
183 # but we can read from it
184 ok(open(F, '<', $ro), $!);
190 # Check that we zero fill when needed when seeking,
191 # and that seeking negative off the string does not do bad things.
195 ok(open(F, '>', \$foo));
197 # Seeking forward should zero fill.
199 ok(seek(F, 50, SEEK_SET));
201 is(length($foo), 51);
202 like($foo, qr/^\0{50}x$/);
205 ok(seek(F, 0, SEEK_SET));
206 is(length($foo), 51);
208 # Seeking forward again should zero fill but only the new bytes.
210 ok(seek(F, 100, SEEK_SET));
212 is(length($foo), 101);
213 like($foo, qr/^\0{50}x\0{49}y$/);
216 # Seeking back and writing should not zero fill.
218 ok(seek(F, 75, SEEK_SET));
220 is(length($foo), 101);
221 like($foo, qr/^\0{50}x\0{24}z\0{24}y$/);
224 # Seeking negative should not do funny business.
226 ok(!seek(F, -50, SEEK_SET), $!);
227 ok(seek(F, 0, SEEK_SET));
228 ok(!seek(F, -50, SEEK_CUR), $!);
229 ok(!seek(F, -150, SEEK_END), $!);