t/op/readline.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 plan tests => 30;
  10
  11 # [perl #19566]: sv_gets writes directly to its argument via
  12 # TARG. Test that we respect SvREADONLY.
  13 eval { for (\2) { $_ = <FH> } };
  14 like($@, 'Modification of a read-only value attempted', '[perl #19566]');
  15
  16 # [perl #21628]
  17 {
  18   my $file = tempfile();
  19   open A,'+>',$file; $a = 3;
  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');
  23 }
  24
  25 # [perl #21614]: 82 is chosen to exceed the length for sv_grow in
  26 # do_readline (80)
  27 foreach my $k (1, 82) {
  28   my $result
  29     = runperl (stdin => '', stderr => 1,
  30               prog => "\$x = q(k) x $k; \$a{\$x} = qw(v); \$_ = <> foreach keys %a; print qw(end)",
  31               );
  32   $result =~ s/\n\z// if $^O eq 'VMS';
  33   is ($result, "end", '[perl #21614] for length ' . length('k' x $k));
  34 }
  35
  36
  37 foreach my $k (1, 21) {
  38   my $result
  39     = runperl (stdin => ' rules', stderr => 1,
  40               prog => "\$x = q(perl) x $k; \$a{\$x} = q(v); foreach (keys %a) {\$_ .= <>; print}",
  41               );
  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));
  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 }
  62
  63 use strict;
  64
  65 open F, '.' and sysread F, $_, 1;
  66 my $err = $! + 0;
  67 close F;
  68
  69 SKIP: {
  70   skip "you can read directories as plain files", 2 unless( $err );
  71
  72   $!=0;
  73   open F, '.' and $_=<F>;
  74   ok( $!==$err && !defined($_) => 'readline( DIRECTORY )' );
  75   close F;
  76
  77   $!=0;
  78   { local $/;
  79     open F, '.' and $_=<F>;
  80     ok( $!==$err && !defined($_) => 'readline( DIRECTORY ) slurp mode' );
  81     close F;
  82   }
  83 }
  84
  85 fresh_perl_is('BEGIN{<>}', '',
  86               { switches => ['-w'], stdin => '', stderr => 1 },
  87               'No ARGVOUT used only once warning');
  88
  89 fresh_perl_is('print readline', 'foo',
  90               { switches => ['-w'], stdin => 'foo', stderr => 1 },
  91               'readline() defaults to *ARGV');
  92
  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 );
 168     is(   $once,  "once\n", "readline read first line ok" );
 169
 170     my $twice;
 171     TODO: {
 172         todo_skip( 'alarm() on Windows does not interrupt system calls' ) if $^O eq 'MSWin32';
 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: {
 179         todo_skip( 'alarm() on Windows does not interrupt system calls' ) if $^O eq 'MSWin32';
 180         todo_skip( 'readline not interrupted by alarm on VMS -- why?' ) if $^O eq 'VMS';
 181         local our $TODO = "bad readline returns '', not undef";
 182         is( $twice, undef, "readline returned undef when interrupted" );
 183     }
 184 }
 185
 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
 234 my $obj = bless [];
 235 $obj .= <DATA>;
 236 like($obj, qr/main=ARRAY.*world/, 'rcatline and refs');
 237
 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
 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
 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';
 269 readline *{$f{g}};
 270 is tell, tell *foom, 'readline *$glob_copy sets PL_last_in_gv';
 271
 272 __DATA__
 273 moo
 274 moo
 275  rules
 276  rules
 277 world
 278 One
 279 Two