diff --git a/MANIFEST b/MANIFEST index c6d980cc8c8e..dcfac3f10667 100644 --- a/MANIFEST +++ b/MANIFEST @@ -6410,6 +6410,7 @@ t/op/range.t See if .. works t/op/read.t See if read() works t/op/readdir.t See if readdir() works t/op/readline.t See if <> / readline / rcatline work +t/op/readline_nb.t Test <> error handling on non-blocking handles t/op/recurse.t See if deep recursion works t/op/ref.t See if refs and objects work t/op/refstack.t See if a ref counted stack fixes things diff --git a/pod/perldelta.pod b/pod/perldelta.pod index e0c3a7a72c16..75852967b3bb 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -378,7 +378,10 @@ manager will later use a regex to expand these into links. =item * -XXX +L now clears the error flag if an error occurs when +reading and that error is C or C. This allows +old code that depended on C to clear all errors to ignore +these relatively harmless errors. [GH #22883] =back diff --git a/pp_hot.c b/pp_hot.c index 2f17ad7df292..357f02752d1a 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -3994,6 +3994,21 @@ PP(pp_match) return NORMAL; } +/* errno can be either EAGAIN or EWOULDBLOCK for a socket() read that + is non-blocking but would have blocked if blocking +*/ +PERL_STATIC_INLINE bool +error_is_would_block(int err) { +#ifdef EAGAIN + if (err == EAGAIN) + return true; +#endif +#ifdef EWOULDBLOCK + if (err == EWOULDBLOCK) + return true; +#endif + return false; +} /* Perl_do_readline(): implement <$fh>, readline($fh) and glob('*.h') * @@ -4236,6 +4251,9 @@ Perl_do_readline(pTHX) (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); } } + else if (error_is_would_block(errno)) { + PerlIO_clearerr(fp); + } if (gimme == G_SCALAR) { if (type != OP_RCATLINE) { diff --git a/t/op/readline_nb.t b/t/op/readline_nb.t new file mode 100644 index 000000000000..8c8037eefd07 --- /dev/null +++ b/t/op/readline_nb.t @@ -0,0 +1,36 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + require './test.pl'; + set_up_inc('../lib'); + require Config; Config->import; + + skip_all_if_miniperl(); +} + +use strict; +use IO::Select; + +$Config{d_pipe} + or skip_all("No pipe"); + +my ($in, $out); +pipe($in, $out) + or skip_all("Cannot pipe: $!"); + +$in->blocking(0) + or skip_all("Cannot make pipe non-blocking"); + +my $line = <$in>; +is($line, undef, "error reading"); +ok(!$in->error, "but did not set error flag"); +close $out; +$line = <$in>; +is($line, undef, "nothing to read, but eof"); +ok(!$in->error, "still did not set error flag"); +ok($in->eof, "did set eof"); +ok(close($in), "close success"); + + +done_testing();