Test that print() is not returning EINTR.

fails under 5.14.x ( see RT #119097 )
also fails under 5.8.x

Currently test enabled on linux/bsd/solaris/darwin

1 files changed, 87 insertions, 0 deletions

diff --git a/t/io/eintr_print.t b/t/io/eintr_print.t
new file mode 100644
index 0000000000..56ab5b4a3d
--- /dev/null
+++ b/t/io/eintr_print.t
@@ -0,0 +1,87 @@
+#!./perl
+
+# print should not return EINTR
+# fails under 5.14.x see https://rt.perl.org/rt3/Ticket/Display.html?id=119097
+# also fails under 5.8.x
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+use strict;
+use warnings;
+
+use Config;
+use Time::HiRes;
+use IO::Handle;
+
+require './test.pl';
+
+skip_all("only for dev versions for now") if ((int($]*1000) & 1) == 0);
+skip_all("does not match platform whitelist")
+    unless ($^O =~ /^(linux|.*bsd|darwin|solaris)$/);
+skip_all("ualarm() not implemented on this platform")
+    unless Time::HiRes::d_ualarm();
+skip_all("usleep() not implemented on this platform")
+    unless Time::HiRes::d_usleep();
+skip_all("pipe not implemented on this platform")
+    unless eval { pipe my $in, my $out; 1; };
+
+my $sample = 'abxhrtf6';
+my $full_sample = 'abxhrtf6' x (8192-7);
+my $sample_l = length $full_sample;
+
+my $ppid = $$;
+
+pipe my $in, my $out;
+
+my $small_delay = 10_000;
+my $big_delay = $small_delay * 3;
+my $fail_delay = 20_000_000;
+
+if (my $pid = fork()) {
+    plan(tests => 20);
+
+    local $SIG{ALRM} = sub { print STDERR "FAILED $$\n"; exit(1) };
+    my $child_exited = 0;
+    $in->autoflush(1);
+    $in->blocking(1);
+    binmode $in, ":perlio";
+
+    Time::HiRes::usleep $big_delay;
+
+    # in case test fail it should not hang, however this is not always helping
+    Time::HiRes::ualarm($fail_delay);
+    for (1..10) {
+	my $n = read($in, my $x, $sample_l);
+	die "EOF" unless $n;
+
+	# should return right amount of data
+	is($n, $sample_l);
+
+	# should return right data
+	# don't use "is()" as output in case of fail is big and useless
+	ok($x eq $full_sample);
+    }
+    Time::HiRes::ualarm(0);
+
+    while(wait() != -1 ){};
+} else {
+    local $SIG{ALRM} = sub { print "# ALRM $$\n" };
+    $out->autoflush(1);
+    $out->blocking(1);
+    binmode $out, ":perlio";
+
+    for (1..10) { # on some iteration print() will block
+	Time::HiRes::ualarm($small_delay); # and when it block we'll get SIGALRM
+	# it should unblock and continue after $big_delay
+	die "print failed [ $! ]" unless print($out $full_sample);
+	Time::HiRes::ualarm(0);
+    }
+
+    exit(0);
+}
+
+1;
+