Commit | Line | Data |
---|---|---|
79628082 SM |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't'; | |
5 | @INC = '../lib'; | |
6 | require './test.pl'; | |
7 | } | |
8 | ||
b73e5385 | 9 | plan tests => 30; |
79628082 | 10 | |
5b88351f JJ |
11 | # [perl #19566]: sv_gets writes directly to its argument via |
12 | # TARG. Test that we respect SvREADONLY. | |
79628082 SM |
13 | eval { for (\2) { $_ = <FH> } }; |
14 | like($@, 'Modification of a read-only value attempted', '[perl #19566]'); | |
15 | ||
5b88351f | 16 | # [perl #21628] |
ba92458f | 17 | { |
1c25d394 NC |
18 | my $file = tempfile(); |
19 | open A,'+>',$file; $a = 3; | |
ba92458f AE |
20 | is($a .= <A>, 3, '#21628 - $a .= <A> , A eof'); |
21 | close A; $a = 4; | |
22 | is($a .= <A>, 4, '#21628 - $a .= <A> , A closed'); | |
ba92458f | 23 | } |
10bcdfd6 | 24 | |
5b88351f JJ |
25 | # [perl #21614]: 82 is chosen to exceed the length for sv_grow in |
26 | # do_readline (80) | |
bfe0b846 | 27 | foreach my $k (1, 82) { |
10bcdfd6 | 28 | my $result |
048e6480 | 29 | = runperl (stdin => '', stderr => 1, |
bfe0b846 | 30 | prog => "\$x = q(k) x $k; \$a{\$x} = qw(v); \$_ = <> foreach keys %a; print qw(end)", |
10bcdfd6 | 31 | ); |
bfe0b846 CB |
32 | $result =~ s/\n\z// if $^O eq 'VMS'; |
33 | is ($result, "end", '[perl #21614] for length ' . length('k' x $k)); | |
10bcdfd6 | 34 | } |
bc44a8a2 NC |
35 | |
36 | ||
bfe0b846 | 37 | foreach my $k (1, 21) { |
bc44a8a2 | 38 | my $result |
048e6480 | 39 | = runperl (stdin => ' rules', stderr => 1, |
bfe0b846 | 40 | prog => "\$x = q(perl) x $k; \$a{\$x} = q(v); foreach (keys %a) {\$_ .= <>; print}", |
bc44a8a2 | 41 | ); |
bfe0b846 CB |
42 | $result =~ s/\n\z// if $^O eq 'VMS'; |
43 | is ($result, ('perl' x $k) . " rules", 'rcatline to shared sv for length ' . length('perl' x $k)); | |
bc44a8a2 NC |
44 | } |
45 | ||
46 | foreach my $l (1, 82) { | |
47 | my $k = $l; | |
48 | $k = 'k' x $k; | |
49 | my $copy = $k; | |
50 | $k = <DATA>; | |
51 | is ($k, "moo\n", 'catline to COW sv for length ' . length $copy); | |
52 | } | |
53 | ||
54 | ||
55 | foreach my $l (1, 21) { | |
56 | my $k = $l; | |
57 | $k = 'perl' x $k; | |
58 | my $perl = $k; | |
59 | $k .= <DATA>; | |
60 | is ($k, "$perl rules\n", 'rcatline to COW sv for length ' . length $perl); | |
61 | } | |
2d726892 TF |
62 | |
63 | use strict; | |
2d726892 | 64 | |
519ecd2c | 65 | open F, '.' and sysread F, $_, 1; |
2d726892 TF |
66 | my $err = $! + 0; |
67 | close F; | |
68 | ||
69 | SKIP: { | |
389edf24 | 70 | skip "you can read directories as plain files", 2 unless( $err ); |
2d726892 TF |
71 | |
72 | $!=0; | |
519ecd2c | 73 | open F, '.' and $_=<F>; |
2d726892 TF |
74 | ok( $!==$err && !defined($_) => 'readline( DIRECTORY )' ); |
75 | close F; | |
76 | ||
77 | $!=0; | |
78 | { local $/; | |
519ecd2c | 79 | open F, '.' and $_=<F>; |
2d726892 TF |
80 | ok( $!==$err && !defined($_) => 'readline( DIRECTORY ) slurp mode' ); |
81 | close F; | |
82 | } | |
83 | } | |
84 | ||
7b8203e3 YST |
85 | fresh_perl_is('BEGIN{<>}', '', |
86 | { switches => ['-w'], stdin => '', stderr => 1 }, | |
87 | 'No ARGVOUT used only once warning'); | |
88 | ||
e4b7ebf3 RGS |
89 | fresh_perl_is('print readline', 'foo', |
90 | { switches => ['-w'], stdin => 'foo', stderr => 1 }, | |
91 | 'readline() defaults to *ARGV'); | |
92 | ||
fd2c61bc JJ |
93 | # [perl #72720] Test that sv_gets clears any variables that should be |
94 | # empty so if the read() aborts with EINTER, the TARG is actually | |
95 | # cleared. | |
96 | sub test_eintr_readline { | |
97 | my ( $fh, $timeout ) = @_; | |
98 | ||
99 | # This variable, the TARG for the readline is the core of this | |
100 | # test. The test is to see that after a my() and a failure in | |
101 | # readline() has the variable revived old, "dead" values from the | |
102 | # past or is it still undef like expected. | |
103 | my $line; | |
104 | ||
105 | # Do a readline into $line. | |
106 | if ( $timeout ) { | |
107 | ||
108 | # Do a SIGALARM aborted readline(). The underlying sv_gets() | |
109 | # from sv.c will use the syscall read() while will exit early | |
110 | # and return something like EINTR or ERESTARTSYS. | |
111 | my $timed_out; | |
112 | my $errno; | |
113 | eval { | |
114 | local $SIG{ALRM} = sub { | |
115 | $timed_out = 1; | |
116 | die 'abort this timeout'; | |
117 | }; | |
118 | alarm $timeout; | |
119 | undef $!; | |
120 | $line = readline $fh; | |
121 | $errno = $!; | |
122 | alarm 0; | |
123 | }; | |
124 | ||
125 | # The code should have timed out. | |
126 | if ( ! $timed_out ) { | |
127 | warn $@ | |
128 | ? "$@: $errno\n" | |
129 | : "Interrupted readline() test couldn't get interrupted: $errno"; | |
130 | } | |
131 | } | |
132 | else { | |
133 | $line = readline $fh; | |
134 | } | |
135 | return $line; | |
136 | } | |
137 | SKIP: { | |
138 | ||
139 | # Connect two handles together. | |
140 | my ( $in, $out ); | |
141 | my $piped; | |
142 | eval { | |
143 | pipe $in, $out; | |
144 | $piped = 1; | |
145 | }; | |
146 | if ( ! $piped ) { | |
147 | skip( 2, 'The pipe function is unimplemented' ); | |
148 | } | |
149 | ||
150 | # Make the pipe autoflushing | |
151 | { | |
152 | my $old_fh = select $out; | |
153 | $| = 1; | |
154 | select $old_fh; | |
155 | } | |
156 | ||
157 | # Only one line is loaded into the pipe. It's written unbuffered | |
158 | # so I'm confident it'll not be buffered. | |
159 | syswrite $out, "once\n"; | |
160 | ||
161 | # Buggy perls will return the last thing successfully | |
162 | # returned. Buggy perls will return "once\n" a second (and | |
163 | # "infinitely" if we desired) as long as the internal read() | |
164 | # syscall fails. In our case, it fails because the inner my($line) | |
165 | # retains all its allocated space and buggy perl sets SvPOK to | |
166 | # make the value valid but before it starts read(). | |
167 | my $once = test_eintr_readline( $in, 0 ); | |
7a0f0843 | 168 | is( $once, "once\n", "readline read first line ok" ); |
fd2c61bc | 169 | |
23fe4d6e | 170 | my $twice; |
fd2c61bc | 171 | TODO: { |
4a8201af | 172 | todo_skip( 'alarm() on Windows does not interrupt system calls' ) if $^O eq 'MSWin32'; |
23fe4d6e CB |
173 | todo_skip( 'readline not interrupted by alarm on VMS -- why?' ) if $^O eq 'VMS'; |
174 | $twice = test_eintr_readline( $in, 1 ); | |
175 | isnt( $twice, "once\n", "readline didn't re-return things when interrupted" ); | |
176 | } | |
177 | ||
178 | TODO: { | |
4a8201af | 179 | todo_skip( 'alarm() on Windows does not interrupt system calls' ) if $^O eq 'MSWin32'; |
23fe4d6e | 180 | todo_skip( 'readline not interrupted by alarm on VMS -- why?' ) if $^O eq 'VMS'; |
fd2c61bc | 181 | local our $TODO = "bad readline returns '', not undef"; |
7a0f0843 | 182 | is( $twice, undef, "readline returned undef when interrupted" ); |
fd2c61bc JJ |
183 | } |
184 | } | |
185 | ||
4e86d350 JJ |
186 | { |
187 | my $line = 'ascii'; | |
188 | my ( $in, $out ); | |
189 | pipe $in, $out; | |
190 | binmode $in; | |
191 | binmode $out; | |
192 | syswrite $out, "...\n"; | |
193 | $line .= readline $in; | |
194 | ||
195 | is( $line, "ascii...\n", 'Appending from ascii to ascii' ); | |
196 | } | |
197 | ||
198 | { | |
199 | my $line = "\x{2080} utf8"; | |
200 | my ( $in, $out ); | |
201 | pipe $in, $out; | |
202 | binmode $out; | |
203 | binmode $in; | |
204 | syswrite $out, "...\n"; | |
205 | $line .= readline $in; | |
206 | ||
207 | is( $line, "\x{2080} utf8...\n", 'Appending from ascii to utf8' ); | |
208 | } | |
209 | ||
210 | { | |
211 | my $line = 'ascii'; | |
212 | my ( $in, $out ); | |
213 | pipe $in, $out; | |
214 | binmode $out, ':utf8'; | |
215 | binmode $in, ':utf8'; | |
216 | syswrite $out, "...\n"; | |
217 | $line .= readline $in; | |
218 | ||
219 | is( $line, "ascii...\n", 'Appending from utf8 to ascii' ); | |
220 | } | |
221 | ||
222 | { | |
223 | my $line = "\x{2080} utf8";; | |
224 | my ( $in, $out ); | |
225 | pipe $in, $out; | |
226 | binmode $out, ':utf8'; | |
227 | binmode $in, ':utf8'; | |
228 | syswrite $out, "\x{2080}...\n"; | |
229 | $line .= readline $in; | |
230 | ||
231 | is( $line, "\x{2080} utf8\x{2080}...\n", 'appending from utf to utf8' ); | |
232 | } | |
233 | ||
48de12d9 RGS |
234 | my $obj = bless []; |
235 | $obj .= <DATA>; | |
236 | like($obj, qr/main=ARRAY.*world/, 'rcatline and refs'); | |
237 | ||
0f722b55 RGS |
238 | # bug #38631 |
239 | require Tie::Scalar; | |
240 | tie our $one, 'Tie::StdScalar', "A: "; | |
241 | tie our $two, 'Tie::StdScalar', "B: "; | |
242 | my $junk = $one; | |
243 | $one .= <DATA>; | |
244 | $two .= <DATA>; | |
245 | is( $one, "A: One\n", "rcatline works with tied scalars" ); | |
246 | is( $two, "B: Two\n", "rcatline works with tied scalars" ); | |
247 | ||
e59953eb FC |
248 | # mentioned in bug #97482 |
249 | # <$foo> versus readline($foo) should not affect vivification. | |
250 | my $yunk = "brumbo"; | |
251 | if (exists $::{$yunk}) { | |
252 | die "Name $yunk already used. Please adjust this test." | |
253 | } | |
254 | <$yunk>; | |
255 | ok !defined *$yunk, '<> does not autovivify'; | |
256 | readline($yunk); | |
257 | ok !defined *$yunk, "readline does not autovivify"; | |
258 | ||
69930016 FC |
259 | # [perl #97988] PL_last_in_gv could end up pointing to junk. |
260 | # Now glob copies set PL_last_in_gv to null when unglobbed. | |
261 | open *foom,'test.pl'; | |
262 | my %f; | |
263 | $f{g} = *foom; | |
264 | readline $f{g}; | |
265 | $f{g} = 3; # PL_last_in_gv should be cleared now | |
266 | is tell, -1, 'tell returns -1 after last gv is unglobbed'; | |
267 | $f{g} = *foom; # since PL_last_in_gv is null, this should have no effect | |
268 | is tell, -1, 'unglobbery of last gv nullifies PL_last_in_gv'; | |
b73e5385 FC |
269 | readline *{$f{g}}; |
270 | is tell, tell *foom, 'readline *$glob_copy sets PL_last_in_gv'; | |
69930016 | 271 | |
bc44a8a2 NC |
272 | __DATA__ |
273 | moo | |
274 | moo | |
275 | rules | |
276 | rules | |
48de12d9 | 277 | world |
0f722b55 RGS |
278 | One |
279 | Two |