t/op/readline.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     require './test.pl';
   6     set_up_inc('../lib');
   7 }
   8
   9 plan tests => 36;
  10
  11 # [perl #19566]: sv_gets writes directly to its argument via
  12 # TARG. Test that we respect SvREADONLY.
  13 use constant roref => \2;
  14 eval { for (roref) { $_ = <FH> } };
  15 like($@, 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)
  28 foreach 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
  38 foreach 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
  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 }
  63
  64 use strict;
  65
  66 open F, '.' and binmode F and sysread F, $_, 1;
  67 my $err = $! + 0;
  68 close F;
  69
  70 SKIP: {
  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
  86 fresh_perl_is('BEGIN{<>}', '',
  87               { switches => ['-w'], stdin => '', stderr => 1 },
  88               'No ARGVOUT used only once warning');
  89
  90 fresh_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.
  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     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
 240 my $obj = bless [];
 241 $obj .= <DATA>;
 242 like($obj, qr/main=ARRAY.*world/, 'rcatline and refs');
 243
 244 # bug #38631
 245 require Tie::Scalar;
 246 tie our $one, 'Tie::StdScalar', "A: ";
 247 tie our $two, 'Tie::StdScalar', "B: ";
 248 my $junk = $one;
 249 $one .= <DATA>;
 250 $two .= <DATA>;
 251 is( $one, "A: One\n", "rcatline works with tied scalars" );
 252 is( $two, "B: Two\n", "rcatline works with tied scalars" );
 253
 254 # mentioned in bug #97482
 255 # <$foo> versus readline($foo) should not affect vivification.
 256 my $yunk = "brumbo";
 257 if (exists $::{$yunk}) {
 258      die "Name $yunk already used. Please adjust this test."
 259 }
 260 <$yunk>;
 261 ok !defined *$yunk, '<> does not autovivify';
 262 readline($yunk);
 263 ok !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.
 267 open *foom,'test.pl';
 268 my %f;
 269 $f{g} = *foom;
 270 readline $f{g};
 271 $f{g} = 3; # PL_last_in_gv should be cleared now
 272 is 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
 274 is tell, -1, 'unglobbery of last gv nullifies PL_last_in_gv';
 275 readline *{$f{g}};
 276 is 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.
 280 readline undef;
 281 is ${^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 SKIP:
 293 {
 294     skip_without_dynamic_extension("IO", 4);
 295     my $tmpfile = tempfile();
 296     open my $fh, ">", $tmpfile
 297         or die "Cannot open $tmpfile: $!";
 298     my @layers = PerlIO::get_layers($fh);
 299     skip "fgetc doesn't set error flag on failure on solaris likes", 4
 300         if $^O eq 'solaris' && $layers[-1] eq 'stdio';
 301     ok(!$fh->error, "no error before we try to read");
 302     ok(!<$fh>, "fail to readline file opened for write");
 303     ok($fh->error, "error after trying to readline file opened for write");
 304     ok(!close($fh), "closing the file should fail");
 305 }
 306
 307 __DATA__
 308 moo
 309 moo
 310  rules
 311  rules
 312 world
 313 One
 314 Two