X-Git-Url: http://www.git.stargrave.org/?a=blobdiff_plain;f=t%2Frun.perl;h=cf80a8a17ecedc54304d5280744e5b5d857e4209;hb=4eee5af6011cc8cdefb66c9729952c7eff5c0b0b;hp=017ca3e82c72be9f2e0665be26121129b3f9ac75;hpb=cffc7d4fc1c36169654f8447b23b3c5c43830eed;p=public-inbox.git diff --git a/t/run.perl b/t/run.perl index 017ca3e8..cf80a8a1 100755 --- a/t/run.perl +++ b/t/run.perl @@ -1,5 +1,5 @@ #!/usr/bin/perl -w -# Copyright (C) 2019-2020 all contributors +# Copyright (C) 2019-2021 all contributors # License: AGPL-3.0+ # # Parallel test runner which preloads code and reuses worker processes @@ -11,11 +11,15 @@ # Usage: $PERL -I lib -w t/run.perl -j4 # Or via prove(1): prove -lvw t/run.perl :: -j4 use strict; +use v5.10.1; +use IO::Handle; # ->autoflush use PublicInbox::TestCommon; -use Cwd qw(getcwd); +use PublicInbox::Spawn; use Getopt::Long qw(:config gnu_getopt no_ignore_case auto_abbrev); use Errno qw(EINTR); -use POSIX qw(_POSIX_PIPE_BUF WNOHANG); +use Fcntl qw(:seek); +use POSIX qw(WNOHANG); +use File::Temp (); my $jobs = 1; my $repeat = 1; $| = 1; @@ -30,14 +34,49 @@ if (($ENV{TEST_RUN_MODE} // 2) == 0) { die "$0 is not compatible with TEST_RUN_MODE=0\n"; } my @tests = scalar(@ARGV) ? @ARGV : glob('t/*.t'); -my $cwd = getcwd(); -open OLDOUT, '>&STDOUT' or die "dup STDOUT: $!"; -open OLDERR, '>&STDERR' or die "dup STDERR: $!"; -OLDOUT->autoflush(1); -OLDERR->autoflush(1); +open my $cwd_fh, '<', '.' or die "open .: $!"; +open my $OLDOUT, '>&STDOUT' or die "dup STDOUT: $!"; +open my $OLDERR, '>&STDERR' or die "dup STDERR: $!"; +$OLDOUT->autoflush(1); +$OLDERR->autoflush(1); + +my ($run_log, $tmp_rl); +my $rl = $ENV{TEST_RUN_LOG}; +unless ($rl) { + $tmp_rl = File::Temp->new(CLEANUP => 1); + $rl = $tmp_rl->filename; +} +open $run_log, '+>>', $rl or die "open $rl: $!"; +$run_log->autoflush(1); # one reader, many writers key2sub($_) for @tests; # precache +my ($for_destroy, $lei_env, $lei_daemon_pid, $owner_pid); + +# TEST_LEI_DAEMON_PERSIST is currently broken. I get ECONNRESET from +# lei even with high kern.ipc.soacceptqueue=1073741823 or SOMAXCONN, not +# sure why. Also, testing our internal inotify usage is unreliable +# because lei-daemon uses a single inotify FD for all clients. +if ($ENV{TEST_LEI_DAEMON_PERSIST} && !$ENV{TEST_LEI_DAEMON_PERSIST_DIR} && + (PublicInbox::Spawn->can('recv_cmd4') || + eval { require Socket::MsgHdr })) { + $lei_env = {}; + ($lei_env->{XDG_RUNTIME_DIR}, $for_destroy) = tmpdir; + $ENV{TEST_LEI_DAEMON_PERSIST_DIR} = $lei_env->{XDG_RUNTIME_DIR}; + run_script([qw(lei daemon-pid)], $lei_env, { 1 => \$lei_daemon_pid }); + chomp $lei_daemon_pid; + $lei_daemon_pid =~ /\A[0-9]+\z/ or die "no daemon pid: $lei_daemon_pid"; + kill(0, $lei_daemon_pid) or die "kill $lei_daemon_pid: $!"; + if (my $t = $ENV{GNU_TAIL}) { + system("$t --pid=$lei_daemon_pid -F " . + "$lei_env->{XDG_RUNTIME_DIR}/lei/errors.log >&2 &"); + } + if (my $strace_cmd = $ENV{STRACE_CMD}) { + system("$strace_cmd -p $lei_daemon_pid &"); + } + $owner_pid = $$; +} + if ($shuffle) { require List::Util; } elsif (open(my $prove_state, '<', '.prove') && eval { require YAML::XS }) { @@ -52,7 +91,7 @@ if ($shuffle) { our $tb = Test::More->builder; sub DIE (;$) { - print OLDERR @_; + print $OLDERR @_; exit(1); } @@ -61,7 +100,34 @@ our ($worker, $worker_test); sub test_status () { $? = 255 if $? == 0 && !$tb->is_passing; my $status = $? ? 'not ok' : 'ok'; - print OLDOUT "$status $worker_test\n" if $log_suffix ne ''; + chdir($cwd_fh) or DIE "fchdir: $!"; + if ($log_suffix ne '') { + my $log = $worker_test; + $log =~ s/\.t\z/$log_suffix/; + my $skip = ''; + if (open my $fh, '<', $log) { + my @not_ok = grep(!/^(?:ok |[ \t]*#)/ms, <$fh>); + my $last = $not_ok[-1] // ''; + pop @not_ok if $last =~ /^[0-9]+\.\.[0-9]+$/; + my $pfx = "# $log: "; + print $OLDERR map { $pfx.$_ } @not_ok; + seek($fh, 0, SEEK_SET) or die "seek: $!"; + + # show unique skip texts and the number of times + # each text was skipped + local $/; + my @sk = (<$fh> =~ m/^ok [0-9]+ (# skip [^\n]+)/mgs); + if (@sk) { + my %nr; + my @err = grep { !$nr{$_}++ } @sk; + print $OLDERR "$pfx$_ ($nr{$_})\n" for @err; + $skip = ' # total skipped: '.scalar(@sk); + } + } else { + print $OLDERR "could not open: $log: $!\n"; + } + print $OLDOUT "$status $worker_test$skip\n"; + } } # Test::Builder or Test2::Hub may call exit() from plan(skip_all => ...) @@ -69,6 +135,7 @@ END { test_status() if (defined($worker_test) && $worker == $$) } sub run_test ($) { my ($test) = @_; + syswrite($run_log, "$$ $test\n"); my $log_fh; if ($log_suffix ne '') { my $log = $test; @@ -97,9 +164,11 @@ my $producer = $$; my $eof; # we stop respawning if true my $start_worker = sub { - my ($i, $j, $rd, $todo) = @_; - defined(my $pid = fork) or DIE "fork: $!"; + my ($j, $rd, $wr, $todo) = @_; + my $pid = fork // DIE "fork: $!"; if ($pid == 0) { + close $wr if $wr; + $SIG{USR1} = undef; # undo parent $SIG{USR1} $worker = $$; while (1) { my $r = sysread($rd, my $buf, UINT_SIZE); @@ -112,10 +181,12 @@ my $start_worker = sub { my $t = unpack('I', $buf); run_test($todo->[$t]); $tb->reset; - chdir($cwd) or DIE "chdir: $!"; } kill 'USR1', $producer if !$eof; # sets $eof in $producer - DIE join('', map { "E: $_\n" } @err) if @err; + if (@err) { # write to run_log for $sigchld handler + syswrite($run_log, "$$ @err\n"); + DIE join('', map { "E: $_\n" } @err); + } exit(0); } else { $pids{$pid} = $j; @@ -126,15 +197,16 @@ my $start_worker = sub { for (my $i = $repeat; $i != 0; $i--) { my @todo = $shuffle ? List::Util::shuffle(@tests) : @tests; - # single-producer, multi-consumer queue relying on POSIX semantics + # single-producer, multi-consumer queue relying on POSIX pipe semantics + # POSIX.1-2008 stipulates a regular file should work, but Linux <3.14 + # had broken read(2) semantics according to the read(2) manpage pipe(my ($rd, $wr)) or DIE "pipe: $!"; # fill the queue before forking so children can start earlier - my $n = (_POSIX_PIPE_BUF / UINT_SIZE); + my $n = (POSIX::PIPE_BUF / UINT_SIZE); if ($n >= $#todo) { print $wr join('', map { pack('I', $_) } (0..$#todo)) or DIE; - close $wr or die; - $wr = undef; + undef $wr; } else { # write what we can... $wr->autoflush(1); print $wr join('', map { pack('I', $_) } (0..$n)) or DIE; @@ -153,30 +225,41 @@ for (my $i = $repeat; $i != 0; $i--) { push @err, "reaped unknown $pid ($?)"; next; } - push @err, "job[$j] ($?)" if $?; + if ($?) { + seek($run_log, 0, SEEK_SET); + chomp(my @t = grep(/^$pid /, <$run_log>)); + $t[0] //= "$pid unknown"; + push @err, "job[$j] ($?) PID=$t[-1]"; + } # skip_all can exit(0), respawn if needed: if (!$eof) { - print OLDERR "# respawning job[$j]\n"; - $start_worker->($i, $j, $rd, \@todo); + print $OLDERR "# respawning job[$j]\n"; + $start_worker->($j, $rd, $wr, \@todo); } } }; # start the workers to consume the queue for (my $j = 0; $j < $jobs; $j++) { - $start_worker->($i, $j, $rd, \@todo); + $start_worker->($j, $rd, $wr, \@todo); } - if ($wr) { local $SIG{CHLD} = $sigchld; # too many tests to fit in the pipe before starting workers, # send the rest now the workers are running print $wr join('', map { pack('I', $_) } ($n..$#todo)) or DIE; - close $wr or die; + undef $wr; } $sigchld->(0) while scalar(keys(%pids)); DIE join('', map { "E: $_\n" } @err) if @err; } -print OLDOUT "1..".($repeat * scalar(@tests))."\n" if $repeat >= 0; +print $OLDOUT "1..".($repeat * scalar(@tests))."\n" if $repeat >= 0; +if ($lei_env && $$ == $owner_pid) { + my $opt = { 1 => $OLDOUT, 2 => $OLDERR }; + my $cur_daemon_pid; + run_script([qw(lei daemon-pid)], $lei_env, { 1 => \$cur_daemon_pid }); + run_script([qw(lei daemon-kill)], $lei_env, $opt); + DIE "lei daemon restarted\n" if $cur_daemon_pid != $lei_daemon_pid; +}