Commit | Line | Data |
f6c77cf1 |
1 | #!./perl |
2 | |
3 | BEGIN { |
0c4f7ff0 |
4 | unless (find PerlIO::Layer 'perlio') { |
f6c77cf1 |
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 |
10 | print "1..0 # Skip -- Perl configured without PerlIO::scalar module\n"; |
11 | exit 0; |
12 | } |
f6c77cf1 |
13 | } |
14 | |
42bc49da |
15 | use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); # Not 0, 1, 2 everywhere. |
16 | |
f6c77cf1 |
17 | $| = 1; |
42bc49da |
18 | |
ffe0bb5a |
19 | use Test::More tests => 69; |
f6c77cf1 |
20 | |
21 | my $fh; |
42bc49da |
22 | my $var = "aaa\n"; |
23 | ok(open($fh,"+<",\$var)); |
24 | |
25 | is(<$fh>, $var); |
26 | |
27 | ok(eof($fh)); |
28 | |
29 | ok(seek($fh,0,SEEK_SET)); |
30 | ok(!eof($fh)); |
31 | |
32 | ok(print $fh "bbb\n"); |
33 | is($var, "bbb\n"); |
f6c77cf1 |
34 | $var = "foo\nbar\n"; |
42bc49da |
35 | ok(seek($fh,0,SEEK_SET)); |
36 | ok(!eof($fh)); |
37 | is(<$fh>, "foo\n"); |
38 | ok(close $fh, $!); |
ae1204bf |
39 | |
40 | # Test that semantics are similar to normal file-based I/O |
41 | # Check that ">" clobbers the scalar |
42 | $var = "Something"; |
43 | open $fh, ">", \$var; |
42bc49da |
44 | is($var, ""); |
ae1204bf |
45 | # Check that file offset set to beginning of scalar |
46 | my $off = tell($fh); |
42bc49da |
47 | is($off, 0); |
ae1204bf |
48 | # Check that writes go where they should and update the offset |
49 | $var = "Something"; |
50 | print $fh "Brea"; |
51 | $off = tell($fh); |
42bc49da |
52 | is($off, 4); |
53 | is($var, "Breathing"); |
c350b88c |
54 | close $fh; |
ae1204bf |
55 | |
56 | # Check that ">>" appends to the scalar |
57 | $var = "Something "; |
c350b88c |
58 | open $fh, ">>", \$var; |
ae1204bf |
59 | $off = tell($fh); |
42bc49da |
60 | is($off, 10); |
61 | is($var, "Something "); |
ae1204bf |
62 | # Check that further writes go to the very end of the scalar |
63 | $var .= "else "; |
42bc49da |
64 | is($var, "Something else "); |
65 | |
ae1204bf |
66 | $off = tell($fh); |
42bc49da |
67 | is($off, 10); |
68 | |
ae1204bf |
69 | print $fh "is here"; |
42bc49da |
70 | is($var, "Something else is here"); |
23a2eb0a |
71 | close $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"; |
76 | open $fh, "<", \$var; |
77 | while (<$fh>) { |
78 | $var = "foo"; |
79 | } |
80 | close $fh; |
42bc49da |
81 | is($var, "foo"); |
ecdeb87c |
82 | |
83 | # Check that dup'ing the handle works |
84 | |
85 | $var = ''; |
ecdeb87c |
86 | open $fh, "+>", \$var; |
42bc49da |
87 | print $fh "xxx\n"; |
ecdeb87c |
88 | open $dup,'+<&',$fh; |
42bc49da |
89 | print $dup "yyy\n"; |
90 | seek($dup,0,SEEK_SET); |
91 | is(<$dup>, "xxx\n"); |
92 | is(<$dup>, "yyy\n"); |
ecdeb87c |
93 | close($fh); |
94 | close($dup); |
95 | |
34fcc551 |
96 | open $fh, '<', \42; |
42bc49da |
97 | is(<$fh>, "42", "reading from non-string scalars"); |
34fcc551 |
98 | close $fh; |
c5b94a97 |
99 | |
ffe0bb5a |
100 | { package P; sub TIESCALAR {bless{}} sub FETCH { "shazam" } sub STORE {} } |
c5b94a97 |
101 | tie $p, P; open $fh, '<', \$p; |
42bc49da |
102 | is(<$fh>, "shazam", "reading from magic scalars"); |
03aa69f9 |
103 | |
104 | { |
105 | use warnings; |
42bc49da |
106 | my $warn = 0; |
107 | local $SIG{__WARN__} = sub { $warn++ }; |
03aa69f9 |
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 |
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 } |
ffe0bb5a |
135 | sub STORE {} |
22ccb26d |
136 | } |
137 | tie my $scalar, MgUndef; |
138 | |
139 | open my $fh, '<', \$scalar; |
140 | close $fh; |
141 | is($warn, 0, "no warnings reading a magical undef scalar"); |
142 | is($fetch, 1, "FETCH only called once"); |
143 | } |
144 | |
145 | { |
146 | use warnings; |
147 | my $warn = 0; |
148 | local $SIG{__WARN__} = sub { $warn++ }; |
149 | my $scalar = 3; |
150 | undef $scalar; |
151 | open my $fh, '<', \$scalar; |
152 | close $fh; |
153 | is($warn, 0, "no warnings reading an undef, allocated scalar"); |
154 | } |
155 | |
47cc46ee |
156 | my $data = "a non-empty PV"; |
157 | $data = undef; |
158 | open(MEM, '<', \$data) or die "Fail: $!\n"; |
159 | my $x = join '', <MEM>; |
42bc49da |
160 | is($x, ''); |
5735c168 |
161 | |
162 | { |
163 | # [perl #35929] verify that works with $/ (i.e. test PerlIOScalar_unread) |
164 | my $s = <<'EOF'; |
165 | line A |
166 | line B |
167 | a third line |
168 | EOF |
169 | open(F, '<', \$s) or die "Could not open string as a file"; |
170 | local $/ = ""; |
171 | my $ln = <F>; |
172 | close F; |
42bc49da |
173 | is($ln, $s, "[perl #35929]"); |
5735c168 |
174 | } |
b35bc0c6 |
175 | |
176 | # [perl #40267] PerlIO::scalar doesn't respect readonly-ness |
177 | { |
42bc49da |
178 | ok(!(defined open(F, '>', \undef)), "[perl #40267] - $!"); |
b35bc0c6 |
179 | close F; |
42bc49da |
180 | |
b35bc0c6 |
181 | my $ro = \43; |
42bc49da |
182 | ok(!(defined open(F, '>', $ro)), $!); |
b35bc0c6 |
183 | close F; |
184 | # but we can read from it |
42bc49da |
185 | ok(open(F, '<', $ro), $!); |
186 | is(<F>, 43); |
b35bc0c6 |
187 | close F; |
188 | } |
42bc49da |
189 | |
190 | { |
191 | # Check that we zero fill when needed when seeking, |
192 | # and that seeking negative off the string does not do bad things. |
193 | |
194 | my $foo; |
195 | |
196 | ok(open(F, '>', \$foo)); |
197 | |
198 | # Seeking forward should zero fill. |
199 | |
200 | ok(seek(F, 50, SEEK_SET)); |
201 | print F "x"; |
202 | is(length($foo), 51); |
203 | like($foo, qr/^\0{50}x$/); |
204 | |
205 | is(tell(F), 51); |
206 | ok(seek(F, 0, SEEK_SET)); |
207 | is(length($foo), 51); |
208 | |
209 | # Seeking forward again should zero fill but only the new bytes. |
210 | |
211 | ok(seek(F, 100, SEEK_SET)); |
212 | print F "y"; |
213 | is(length($foo), 101); |
214 | like($foo, qr/^\0{50}x\0{49}y$/); |
215 | is(tell(F), 101); |
216 | |
217 | # Seeking back and writing should not zero fill. |
218 | |
219 | ok(seek(F, 75, SEEK_SET)); |
220 | print F "z"; |
221 | is(length($foo), 101); |
222 | like($foo, qr/^\0{50}x\0{24}z\0{24}y$/); |
223 | is(tell(F), 76); |
224 | |
225 | # Seeking negative should not do funny business. |
226 | |
227 | ok(!seek(F, -50, SEEK_SET), $!); |
228 | ok(seek(F, 0, SEEK_SET)); |
229 | ok(!seek(F, -50, SEEK_CUR), $!); |
230 | ok(!seek(F, -150, SEEK_END), $!); |
231 | } |
232 | |
ffe0bb5a |
233 | # RT #43789: should respect tied scalar |
234 | |
235 | { |
236 | package TS; |
237 | my $s; |
238 | sub TIESCALAR { bless \my $x } |
239 | sub FETCH { $s .= ':F'; ${$_[0]} } |
240 | sub STORE { $s .= ":S($_[1])"; ${$_[0]} = $_[1] } |
241 | |
242 | package main; |
243 | |
244 | my $x; |
245 | $s = ''; |
246 | tie $x, 'TS'; |
247 | my $fh; |
248 | |
249 | ok(open($fh, '>', \$x), 'open-write tied scalar'); |
250 | $s .= ':O'; |
251 | print($fh 'ABC'); |
252 | $s .= ':P'; |
253 | ok(seek($fh, 0, SEEK_SET)); |
254 | $s .= ':SK'; |
255 | print($fh 'DEF'); |
256 | $s .= ':P'; |
257 | ok(close($fh), 'close tied scalar - write'); |
258 | is($s, ':F:S():O:F:S(ABC):P:F:SK:F:S(DEF):P', 'tied actions - write'); |
259 | is($x, 'DEF', 'new value preserved'); |
260 | |
261 | $x = 'GHI'; |
262 | $s = ''; |
263 | ok(open($fh, '+<', \$x), 'open-read tied scalar'); |
264 | $s .= ':O'; |
265 | my $buf; |
266 | is(read($fh,$buf,2), 2, 'read1'); |
267 | $s .= ':R'; |
268 | is($buf, 'GH', 'buf1'); |
269 | is(read($fh,$buf,2), 1, 'read2'); |
270 | $s .= ':R'; |
271 | is($buf, 'I', 'buf2'); |
272 | is(read($fh,$buf,2), 0, 'read3'); |
273 | $s .= ':R'; |
274 | is($buf, '', 'buf3'); |
275 | ok(close($fh), 'close tied scalar - read'); |
276 | is($s, ':F:S(GHI):O:F:R:F:R:F:R', 'tied actions - read'); |
277 | } |
278 | |
279 | |