This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Rename ext/PerlIO/scalar to ext/PerlIO-scalar
[perl5.git] / ext / PerlIO-scalar / t / scalar.t
CommitLineData
f6c77cf1
NIS
1#!./perl
2
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
0c4f7ff0 6 unless (find PerlIO::Layer 'perlio') {
f6c77cf1
NIS
7 print "1..0 # Skip: not perlio\n";
8 exit 0;
9 }
740dabb8 10 require Config;
98641f60 11 if (($Config::Config{'extensions'} !~ m!\bPerlIO/scalar\b!) ){
740dabb8
NC
12 print "1..0 # Skip -- Perl configured without PerlIO::scalar module\n";
13 exit 0;
14 }
f6c77cf1
NIS
15}
16
42bc49da
JH
17use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); # Not 0, 1, 2 everywhere.
18
f6c77cf1 19$| = 1;
42bc49da 20
22ccb26d 21use Test::More tests => 55;
f6c77cf1
NIS
22
23my $fh;
42bc49da
JH
24my $var = "aaa\n";
25ok(open($fh,"+<",\$var));
26
27is(<$fh>, $var);
28
29ok(eof($fh));
30
31ok(seek($fh,0,SEEK_SET));
32ok(!eof($fh));
33
34ok(print $fh "bbb\n");
35is($var, "bbb\n");
f6c77cf1 36$var = "foo\nbar\n";
42bc49da
JH
37ok(seek($fh,0,SEEK_SET));
38ok(!eof($fh));
39is(<$fh>, "foo\n");
40ok(close $fh, $!);
ae1204bf
BS
41
42# Test that semantics are similar to normal file-based I/O
43# Check that ">" clobbers the scalar
44$var = "Something";
45open $fh, ">", \$var;
42bc49da 46is($var, "");
ae1204bf
BS
47# Check that file offset set to beginning of scalar
48my $off = tell($fh);
42bc49da 49is($off, 0);
ae1204bf
BS
50# Check that writes go where they should and update the offset
51$var = "Something";
52print $fh "Brea";
53$off = tell($fh);
42bc49da
JH
54is($off, 4);
55is($var, "Breathing");
c350b88c 56close $fh;
ae1204bf
BS
57
58# Check that ">>" appends to the scalar
59$var = "Something ";
c350b88c 60open $fh, ">>", \$var;
ae1204bf 61$off = tell($fh);
42bc49da
JH
62is($off, 10);
63is($var, "Something ");
ae1204bf
BS
64# Check that further writes go to the very end of the scalar
65$var .= "else ";
42bc49da
JH
66is($var, "Something else ");
67
ae1204bf 68$off = tell($fh);
42bc49da
JH
69is($off, 10);
70
ae1204bf 71print $fh "is here";
42bc49da 72is($var, "Something else is here");
23a2eb0a
BS
73close $fh;
74
75# Check that updates to the scalar from elsewhere do not
76# cause problems
77$var = "line one\nline two\line three\n";
78open $fh, "<", \$var;
79while (<$fh>) {
80 $var = "foo";
81}
82close $fh;
42bc49da 83is($var, "foo");
ecdeb87c
NIS
84
85# Check that dup'ing the handle works
86
87$var = '';
ecdeb87c 88open $fh, "+>", \$var;
42bc49da 89print $fh "xxx\n";
ecdeb87c 90open $dup,'+<&',$fh;
42bc49da
JH
91print $dup "yyy\n";
92seek($dup,0,SEEK_SET);
93is(<$dup>, "xxx\n");
94is(<$dup>, "yyy\n");
ecdeb87c
NIS
95close($fh);
96close($dup);
97
34fcc551 98open $fh, '<', \42;
42bc49da 99is(<$fh>, "42", "reading from non-string scalars");
34fcc551 100close $fh;
c5b94a97 101
42bc49da 102{ package P; sub TIESCALAR {bless{}} sub FETCH { "shazam" } }
c5b94a97 103tie $p, P; open $fh, '<', \$p;
42bc49da 104is(<$fh>, "shazam", "reading from magic scalars");
03aa69f9
RGS
105
106{
107 use warnings;
42bc49da
JH
108 my $warn = 0;
109 local $SIG{__WARN__} = sub { $warn++ };
03aa69f9
RGS
110 open my $fh, '>', \my $scalar;
111 print $fh "foo";
112 close $fh;
42bc49da 113 is($warn, 0, "no warnings when writing to an undefined scalar");
03aa69f9 114}
47cc46ee 115
22ccb26d
BM
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 }
138 tie my $scalar, MgUndef;
139
140 open my $fh, '<', \$scalar;
141 close $fh;
142 is($warn, 0, "no warnings reading a magical undef scalar");
143 is($fetch, 1, "FETCH only called once");
144}
145
146{
147 use warnings;
148 my $warn = 0;
149 local $SIG{__WARN__} = sub { $warn++ };
150 my $scalar = 3;
151 undef $scalar;
152 open my $fh, '<', \$scalar;
153 close $fh;
154 is($warn, 0, "no warnings reading an undef, allocated scalar");
155}
156
47cc46ee
RGS
157my $data = "a non-empty PV";
158$data = undef;
159open(MEM, '<', \$data) or die "Fail: $!\n";
160my $x = join '', <MEM>;
42bc49da 161is($x, '');
5735c168
RGS
162
163{
164 # [perl #35929] verify that works with $/ (i.e. test PerlIOScalar_unread)
165 my $s = <<'EOF';
166line A
167line B
168a third line
169EOF
170 open(F, '<', \$s) or die "Could not open string as a file";
171 local $/ = "";
172 my $ln = <F>;
173 close F;
42bc49da 174 is($ln, $s, "[perl #35929]");
5735c168 175}
b35bc0c6
RGS
176
177# [perl #40267] PerlIO::scalar doesn't respect readonly-ness
178{
42bc49da 179 ok(!(defined open(F, '>', \undef)), "[perl #40267] - $!");
b35bc0c6 180 close F;
42bc49da 181
b35bc0c6 182 my $ro = \43;
42bc49da 183 ok(!(defined open(F, '>', $ro)), $!);
b35bc0c6
RGS
184 close F;
185 # but we can read from it
42bc49da
JH
186 ok(open(F, '<', $ro), $!);
187 is(<F>, 43);
b35bc0c6
RGS
188 close F;
189}
42bc49da
JH
190
191{
192 # Check that we zero fill when needed when seeking,
193 # and that seeking negative off the string does not do bad things.
194
195 my $foo;
196
197 ok(open(F, '>', \$foo));
198
199 # Seeking forward should zero fill.
200
201 ok(seek(F, 50, SEEK_SET));
202 print F "x";
203 is(length($foo), 51);
204 like($foo, qr/^\0{50}x$/);
205
206 is(tell(F), 51);
207 ok(seek(F, 0, SEEK_SET));
208 is(length($foo), 51);
209
210 # Seeking forward again should zero fill but only the new bytes.
211
212 ok(seek(F, 100, SEEK_SET));
213 print F "y";
214 is(length($foo), 101);
215 like($foo, qr/^\0{50}x\0{49}y$/);
216 is(tell(F), 101);
217
218 # Seeking back and writing should not zero fill.
219
220 ok(seek(F, 75, SEEK_SET));
221 print F "z";
222 is(length($foo), 101);
223 like($foo, qr/^\0{50}x\0{24}z\0{24}y$/);
224 is(tell(F), 76);
225
226 # Seeking negative should not do funny business.
227
228 ok(!seek(F, -50, SEEK_SET), $!);
229 ok(seek(F, 0, SEEK_SET));
230 ok(!seek(F, -50, SEEK_CUR), $!);
231 ok(!seek(F, -150, SEEK_END), $!);
232}
233