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 | |
22ccb26d |
19 | use Test::More tests => 55; |
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 | |
42bc49da |
100 | { package P; sub TIESCALAR {bless{}} sub FETCH { "shazam" } } |
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 } |
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 |
155 | my $data = "a non-empty PV"; |
156 | $data = undef; |
157 | open(MEM, '<', \$data) or die "Fail: $!\n"; |
158 | my $x = join '', <MEM>; |
42bc49da |
159 | is($x, ''); |
5735c168 |
160 | |
161 | { |
162 | # [perl #35929] verify that works with $/ (i.e. test PerlIOScalar_unread) |
163 | my $s = <<'EOF'; |
164 | line A |
165 | line B |
166 | a third line |
167 | EOF |
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 |
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 |
182 | close F; |
183 | # but we can read from it |
42bc49da |
184 | ok(open(F, '<', $ro), $!); |
185 | is(<F>, 43); |
b35bc0c6 |
186 | close F; |
187 | } |
42bc49da |
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 | |