diff options
-rw-r--r-- | .gitignore | 1 | ||||
-rw-r--r-- | MANIFEST | 1 | ||||
-rw-r--r-- | Makefile.PL | 12 | ||||
-rw-r--r-- | lib/PublicInbox/TestCommon.pm | 12 | ||||
-rw-r--r-- | t/nntpd.t | 3 | ||||
-rwxr-xr-x | t/run.perl | 182 |
6 files changed, 205 insertions, 6 deletions
@@ -19,3 +19,4 @@ /NEWS.html /NEWS.atom /NEWS +*.log @@ -265,6 +265,7 @@ t/purge.t t/qspawn.t t/replace.t t/reply.t +t/run.perl t/search-thr-index.t t/search.t t/sigfd.t diff --git a/Makefile.PL b/Makefile.PL index 96c5903b..0f50a658 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -168,8 +168,16 @@ dsyn :: \$(addsuffix .syntax, \$(filter \$(changed), \$(syn_files))) check-manifest :: MANIFEST if git ls-files >\$?.gen 2>&1; then diff -u \$? \$?.gen; fi -check:: pure_all check-manifest - \$(EATMYDATA) \$(PROVE) -bvw -j\$(N) +# the traditional way running per-*.t processes: +check-each :: pure_all check-manifest + \$(EATMYDATA) \$(PROVE) --state=save -bvw -j\$(N) + +# lightly-tested way to runn tests, relies "--state=save" in check-each +# for best performance +check-run :: pure_all check-manifest + \$(EATMYDATA) \$(PROVE) -bvw t/run.perl :: -j\$(N) + +check :: check-each lib/PublicInbox/UserContent.pm :: contrib/css/216dark.css \$(PERL) -I lib \$@ \$? diff --git a/lib/PublicInbox/TestCommon.pm b/lib/PublicInbox/TestCommon.pm index 45306a5a..85cda031 100644 --- a/lib/PublicInbox/TestCommon.pm +++ b/lib/PublicInbox/TestCommon.pm @@ -60,7 +60,7 @@ sub require_git ($;$) { sub key2script ($) { my ($key) = @_; - return $key if $key =~ m!\A/!; + return $key if (index($key, '/') >= 0); # n.b. we may have scripts which don't start with "public-inbox" in # the future: $key =~ s/\A([-\.])/public-inbox$1/; @@ -101,9 +101,11 @@ sub key2sub ($) { my $f = key2script($key); open my $fh, '<', $f or die "open $f: $!"; my $str = do { local $/; <$fh> }; - my ($fc, $rest) = ($key =~ m/([a-z])([a-z0-9]+)\z/); - $fc = uc($fc); - my $pkg = "PublicInbox::TestScript::$fc$rest"; + my $pkg = (split(m!/!, $f))[-1]; + $pkg =~ s/([a-z])([a-z0-9]+)(\.t)?\z/\U$1\E$2/; + $pkg .= "_T" if $3; + $pkg =~ tr/-.//d; + $pkg = "PublicInbox::TestScript::$pkg"; eval <<EOF; package $pkg; use strict; @@ -111,6 +113,8 @@ use subs qw(exit); *exit = *PublicInbox::TestCommon::run_script_exit; sub main { +# the below "line" directive is a magic comment, see perlsyn(1) manpage +# line 1 "$f" $str 0; } @@ -302,6 +302,9 @@ Date: Fri, 02 Oct 1993 00:00:00 +0000 is($? >> 8, 0, 'no errors'); } SKIP: { + if ($INC{'Search/Xapian.pm'} && ($ENV{TEST_RUN_MODE}//1)) { + skip 'Search/Xapian.pm pre-loaded (by t/run.perl?)', 1; + } my @of = `lsof -p $td->{pid} 2>/dev/null`; skip('lsof broken', 1) if (!scalar(@of) || $?); my @xap = grep m!Search/Xapian!, @of; diff --git a/t/run.perl b/t/run.perl new file mode 100755 index 00000000..9f987a6f --- /dev/null +++ b/t/run.perl @@ -0,0 +1,182 @@ +#!/usr/bin/perl -w +# Copyright (C) 2019 all contributors <meta@public-inbox.org> +# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> +# +# Parallel test runner which preloads code and reuses worker processes +# to give a nice speedup over prove(1). It also generates per-test +# .log files (similar to automake tests). +# +# *.t files run by this should not rely on global state. +# +# Usage: $PERL -I lib -w t/run.perl -j4 +# Or via prove(1): prove -lvw t/run.perl :: -j4 +use strict; +use PublicInbox::TestCommon; +use Cwd qw(getcwd); +use Getopt::Long qw(:config gnu_getopt no_ignore_case auto_abbrev); +use Errno qw(EINTR); +use POSIX qw(_POSIX_PIPE_BUF WNOHANG); +my $jobs = 1; +my $repeat = 1; +$| = 1; +our $log_suffix = '.log'; +my ($shuffle, %pids, @err); +GetOptions('j|jobs=i' => \$jobs, + 'repeat=i' => \$repeat, + 'log=s' => \$log_suffix, + 's|shuffle' => \$shuffle, +) or die "Usage: $0 [-j JOBS] [--log=SUFFIX] [--repeat RUNS]"; +if (($ENV{TEST_RUN_MODE} // 1) == 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); + +key2sub($_) for @tests; # precache + +if ($shuffle) { + require List::Util; +} elsif (open(my $prove_state, '<', '.prove') && eval { require YAML::XS }) { + # reuse "prove --state=save" data to start slowest tests, first + my $state = YAML::XS::Load(do { local $/; <$prove_state> }); + my $t = $state->{tests}; + @tests = sort { + ($t->{$b}->{elapsed} // 0) <=> ($t->{$a}->{elapsed} // 0) + } @tests; +} + +our $tb = Test::More->builder; + +sub DIE (;$) { + print OLDERR @_; + exit(1); +} + +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 ''; +} + +# Test::Builder or Test2::Hub may call exit() from plan(skip_all => ...) +END { test_status() if (defined($worker_test) && $worker == $$) } + +sub run_test ($) { + my ($test) = @_; + my $log_fh; + if ($log_suffix ne '') { + my $log = $test; + $log =~ s/\.[^\.]+\z/$log_suffix/ or DIE "can't log for $test"; + open $log_fh, '>', $log or DIE "open $log: $!"; + $log_fh->autoflush(1); + $tb->output($log_fh); + $tb->failure_output($log_fh); + $tb->todo_output($log_fh); + open STDOUT, '>&', $log_fh or DIE "1>$log: $!"; + open STDERR, '>&', $log_fh or DIE "2>$log: $!"; + } + $worker_test = $test; + run_script([$test]); + test_status(); + $worker_test = undef; + push @err, "$test ($?)" if $?; +} + +sub UINT_SIZE () { 4 } + +# worker processes will SIGUSR1 the producer process when it +# sees EOF on the pipe. On FreeBSD 11.2 and Perl 5.30.0, +# sys/ioctl.ph gives the wrong value for FIONREAD(). +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: $!"; + if ($pid == 0) { + $worker = $$; + while (1) { + my $r = sysread($rd, my $buf, UINT_SIZE); + if (!defined($r)) { + next if $! == EINTR; + DIE "sysread: $!"; + } + last if $r == 0; + DIE "short read $r" if $r != UINT_SIZE; + 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; + exit(0); + } else { + $pids{$pid} = $j; + } +}; + +# negative $repeat means loop forever: +for (my $i = $repeat; $i != 0; $i--) { + my @todo = $shuffle ? List::Util::shuffle(@tests) : @tests; + + # single-producer, multi-consumer queue relying on POSIX semantics + pipe(my ($rd, $wr)) or DIE "pipe: $!"; + + # fill the queue before forking so children can start earlier + 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; + } else { # write what we can... + $wr->autoflush(1); + print $wr join('', map { pack('I', $_) } (0..$n)) or DIE; + $n += 1; # and send more ($n..$#todo), later + } + $eof = undef; + local $SIG{USR1} = sub { $eof = 1 }; + my $sigchld = sub { + my ($sig) = @_; + my $flags = $sig ? WNOHANG : 0; + while (1) { + my $pid = waitpid(-1, $flags) or return; + return if $pid < 0; + my $j = delete $pids{$pid}; + if (!defined($j)) { + push @err, "reaped unknown $pid ($?)"; + next; + } + push @err, "job[$j] ($?)" if $?; + # skip_all can exit(0), respawn if needed: + if (!$eof) { + print OLDERR "# respawning job[$j]\n"; + $start_worker->($i, $j, $rd, \@todo); + } + } + }; + + # start the workers to consume the queue + for (my $j = 0; $j < $jobs; $j++) { + $start_worker->($i, $j, $rd, \@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; + } + + $sigchld->(0) while scalar(keys(%pids)); + DIE join('', map { "E: $_\n" } @err) if @err; +} + +print OLDOUT "1..".($repeat * scalar(@tests))."\n" if $repeat >= 0; |