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