1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require './test.pl'; 6 set_up_inc('../lib'); 7} 8 9plan tests => 32; 10 11# [perl #19566]: sv_gets writes directly to its argument via 12# TARG. Test that we respect SvREADONLY. 13use constant roref => \2; 14eval { for (roref) { $_ = <FH> } }; 15like($@, qr/Modification of a read-only value attempted/, '[perl #19566]'); 16 17# [perl #21628] 18{ 19 my $file = tempfile(); 20 open A,'+>',$file; $a = 3; 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'); 24} 25 26# [perl #21614]: 82 is chosen to exceed the length for sv_grow in 27# do_readline (80) 28foreach my $k (1, 82) { 29 my $result 30 = runperl (stdin => '', stderr => 1, 31 prog => "\$x = q(k) x $k; \$a{\$x} = qw(v); \$_ = <> foreach keys %a; print qw(end)", 32 ); 33 $result =~ s/\n\z// if $^O eq 'VMS'; 34 is ($result, "end", '[perl #21614] for length ' . length('k' x $k)); 35} 36 37 38foreach my $k (1, 21) { 39 my $result 40 = runperl (stdin => ' rules', stderr => 1, 41 prog => "\$x = q(perl) x $k; \$a{\$x} = q(v); foreach (keys %a) {\$_ .= <>; print}", 42 ); 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)); 45} 46 47foreach 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 56foreach 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} 63 64use strict; 65 66open F, '.' and binmode F and sysread F, $_, 1; 67my $err = $! + 0; 68close F; 69 70SKIP: { 71 skip "you can read directories as plain files", 2 unless( $err ); 72 73 $!=0; 74 open F, '.' and $_=<F>; 75 ok( $!==$err && !defined($_) => 'readline( DIRECTORY )' ); 76 close F; 77 78 $!=0; 79 { local $/; 80 open F, '.' and $_=<F>; 81 ok( $!==$err && !defined($_) => 'readline( DIRECTORY ) slurp mode' ); 82 close F; 83 } 84} 85 86fresh_perl_is('BEGIN{<>}', '', 87 { switches => ['-w'], stdin => '', stderr => 1 }, 88 'No ARGVOUT used only once warning'); 89 90fresh_perl_is('print readline', 'foo', 91 { switches => ['-w'], stdin => 'foo', stderr => 1 }, 92 'readline() defaults to *ARGV'); 93 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. 97sub 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} 138SKIP: { 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 binmode $out; 152 binmode $in; 153 154 # Make the pipe autoflushing 155 { 156 my $old_fh = select $out; 157 $| = 1; 158 select $old_fh; 159 } 160 161 # Only one line is loaded into the pipe. It's written unbuffered 162 # so I'm confident it'll not be buffered. 163 syswrite $out, "once\n"; 164 165 # Buggy perls will return the last thing successfully 166 # returned. Buggy perls will return "once\n" a second (and 167 # "infinitely" if we desired) as long as the internal read() 168 # syscall fails. In our case, it fails because the inner my($line) 169 # retains all its allocated space and buggy perl sets SvPOK to 170 # make the value valid but before it starts read(). 171 my $once = test_eintr_readline( $in, 0 ); 172 is( $once, "once\n", "readline read first line ok" ); 173 174 my $twice; 175 TODO: { 176 todo_skip( 'alarm() on Windows does not interrupt system calls' ) if $^O eq 'MSWin32'; 177 todo_skip( 'readline not interrupted by alarm on VMS -- why?' ) if $^O eq 'VMS'; 178 $twice = test_eintr_readline( $in, 1 ); 179 isnt( $twice, "once\n", "readline didn't re-return things when interrupted" ); 180 } 181 182 TODO: { 183 todo_skip( 'alarm() on Windows does not interrupt system calls' ) if $^O eq 'MSWin32'; 184 todo_skip( 'readline not interrupted by alarm on VMS -- why?' ) if $^O eq 'VMS'; 185 local our $TODO = "bad readline returns '', not undef"; 186 is( $twice, undef, "readline returned undef when interrupted" ); 187 } 188} 189 190{ 191 my $line = 'ascii'; 192 my ( $in, $out ); 193 pipe $in, $out; 194 binmode $in; 195 binmode $out; 196 syswrite $out, "...\n"; 197 $line .= readline $in; 198 199 is( $line, "ascii...\n", 'Appending from ascii to ascii' ); 200} 201 202{ 203 my $line = "\x{2080} utf8"; 204 my ( $in, $out ); 205 pipe $in, $out; 206 binmode $out; 207 binmode $in; 208 syswrite $out, "...\n"; 209 $line .= readline $in; 210 211 is( $line, "\x{2080} utf8...\n", 'Appending from ascii to utf8' ); 212} 213 214{ 215 my $line = 'ascii'; 216 my ( $in, $out ); 217 pipe $in, $out; 218 binmode $out; 219 binmode $in, ':utf8'; 220 syswrite $out, "...\n"; 221 $line .= readline $in; 222 223 is( $line, "ascii...\n", 'Appending from utf8 to ascii' ); 224} 225 226{ 227 my $line = "\x{2080} utf8";; 228 my ( $in, $out ); 229 pipe $in, $out; 230 binmode $out; 231 binmode $in, ':utf8'; 232 my $outdata = "\x{2080}...\n"; 233 utf8::encode($outdata); 234 syswrite $out, $outdata; 235 $line .= readline $in; 236 237 is( $line, "\x{2080} utf8\x{2080}...\n", 'appending from utf to utf8' ); 238} 239 240my $obj = bless []; 241$obj .= <DATA>; 242like($obj, qr/main=ARRAY.*world/, 'rcatline and refs'); 243 244# bug #38631 245require Tie::Scalar; 246tie our $one, 'Tie::StdScalar', "A: "; 247tie our $two, 'Tie::StdScalar', "B: "; 248my $junk = $one; 249$one .= <DATA>; 250$two .= <DATA>; 251is( $one, "A: One\n", "rcatline works with tied scalars" ); 252is( $two, "B: Two\n", "rcatline works with tied scalars" ); 253 254# mentioned in bug #97482 255# <$foo> versus readline($foo) should not affect vivification. 256my $yunk = "brumbo"; 257if (exists $::{$yunk}) { 258 die "Name $yunk already used. Please adjust this test." 259} 260<$yunk>; 261ok !defined *$yunk, '<> does not autovivify'; 262readline($yunk); 263ok !defined *$yunk, "readline does not autovivify"; 264 265# [perl #97988] PL_last_in_gv could end up pointing to junk. 266# Now glob copies set PL_last_in_gv to null when unglobbed. 267open *foom,'test.pl'; 268my %f; 269$f{g} = *foom; 270readline $f{g}; 271$f{g} = 3; # PL_last_in_gv should be cleared now 272is tell, -1, 'tell returns -1 after last gv is unglobbed'; 273$f{g} = *foom; # since PL_last_in_gv is null, this should have no effect 274is tell, -1, 'unglobbery of last gv nullifies PL_last_in_gv'; 275readline *{$f{g}}; 276is tell, tell *foom, 'readline *$glob_copy sets PL_last_in_gv'; 277 278# PL_last_in_gv should not point to &PL_sv_undef, either. 279# This used to fail an assertion or return a scalar ref. 280readline undef; 281is ${^LAST_FH}, undef, '${^LAST_FH} after readline undef'; 282 283{ 284 my $w; 285 local($SIG{__WARN__},$^W) = (sub { $w .= shift }, 1); 286 *x=<y>; 287 like $w, qr/^readline\(\) on unopened filehandle y at .*\n(?x: 288 )Undefined value assigned to typeglob at .*\n\z/, 289 '[perl #123790] *x=<y> used to fail an assertion'; 290} 291 292__DATA__ 293moo 294moo 295 rules 296 rules 297world 298One 299Two 300