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