* [PATCH 1/6] TODO: add UUCP address item
2019-12-18 3:36 [PATCH 0/6] test updates and speedups Eric Wong
@ 2019-12-18 3:36 ` Eric Wong
2019-12-18 3:36 ` [PATCH 2/6] viewvcs: flesh out some functionality and test Eric Wong
` (4 subsequent siblings)
5 siblings, 0 replies; 10+ messages in thread
From: Eric Wong @ 2019-12-18 3:36 UTC (permalink / raw)
To: meta
We should support historical archives from the old days,
but I'm not sure how to best go about it, for now, given
how tricky correct handling of modern email addresses is.
We can deal with it if/when somebody decides to import some
ancient archives...
---
TODO | 2 ++
1 file changed, 2 insertions(+)
diff --git a/TODO b/TODO
index 0e31e6d7..46c61f8e 100644
--- a/TODO
+++ b/TODO
@@ -141,3 +141,5 @@ all need to be considered for everything we introduce)
* figure out how search for messages with multiple Date: headers
should work (some wacky examples out there...)
+
+* support UUCP addresses for legacy archives
^ permalink raw reply related [flat|nested] 10+ messages in thread* [PATCH 2/6] viewvcs: flesh out some functionality and test
2019-12-18 3:36 [PATCH 0/6] test updates and speedups Eric Wong
2019-12-18 3:36 ` [PATCH 1/6] TODO: add UUCP address item Eric Wong
@ 2019-12-18 3:36 ` Eric Wong
2019-12-18 3:36 ` [PATCH 3/6] Makefile.PL: sort target and var lists Eric Wong
` (3 subsequent siblings)
5 siblings, 0 replies; 10+ messages in thread
From: Eric Wong @ 2019-12-18 3:36 UTC (permalink / raw)
To: meta
Expose MAX_SIZE via "our" will make it possible
to use in tests, and configure, later.
Additionally, returning HTTP 500 code for big files is not an
Internal Server Error, just a memory limit... Some browsers
won't show our HTML response with the link to the raw file in
case of errors, either, so we'll return 200 to ensure users can
use the link to access the raw blob.
Finally, throw in some tests to the existing solver_git testcase,
since that was incomplete and was pointlessly loading Plack
modules without testing PSGI.
---
lib/PublicInbox/ViewVCS.pm | 8 ++--
t/solver_git.t | 77 +++++++++++++++++++++++++++++++++++---
2 files changed, 76 insertions(+), 9 deletions(-)
diff --git a/lib/PublicInbox/ViewVCS.pm b/lib/PublicInbox/ViewVCS.pm
index 369afe93..842c873c 100644
--- a/lib/PublicInbox/ViewVCS.pm
+++ b/lib/PublicInbox/ViewVCS.pm
@@ -28,7 +28,7 @@ my $hl = eval {
};
my %QP_MAP = ( A => 'oid_a', B => 'oid_b', a => 'path_a', b => 'path_b' );
-my $max_size = 1024 * 1024; # TODO: configurable
+our $MAX_SIZE = 1024 * 1024; # TODO: configurable
my $BIN_DETECT = 8000; # same as git
sub html_page ($$$) {
@@ -76,7 +76,7 @@ sub stream_large_blob ($$$$) {
sub show_other ($$$$) {
my ($ctx, $res, $logref, $fn) = @_;
my ($git, $oid, $type, $size) = @$res;
- if ($size > $max_size) {
+ if ($size > $MAX_SIZE) {
$$logref = "$oid is too big to show\n" . $$logref;
return html_page($ctx, 200, $logref);
}
@@ -122,11 +122,11 @@ sub solve_result {
return show_other($ctx, $res, \$log, $fn) if $type ne 'blob';
my $path = to_filename($di->{path_b} || $hints->{path_b} || 'blob');
my $raw_link = "(<a\nhref=$path>raw</a>)";
- if ($size > $max_size) {
+ if ($size > $MAX_SIZE) {
return stream_large_blob($ctx, $res, \$log, $fn) if defined $fn;
$log = "<pre><b>Too big to show, download available</b>\n" .
"$oid $type $size bytes $raw_link</pre>" . $log;
- return html_page($ctx, 500, \$log);
+ return html_page($ctx, 200, \$log);
}
my $blob = $git->cat_file($oid);
diff --git a/t/solver_git.t b/t/solver_git.t
index 9bda157d..6bac17ea 100644
--- a/t/solver_git.t
+++ b/t/solver_git.t
@@ -6,9 +6,9 @@ use Test::More;
use Cwd qw(abs_path);
require './t/common.perl';
require_git(2.6);
+use PublicInbox::Spawn qw(spawn);
-my @mods = qw(DBD::SQLite Search::Xapian HTTP::Request::Common Plack::Test
- URI::Escape Plack::Builder);
+my @mods = qw(DBD::SQLite Search::Xapian);
foreach my $mod (@mods) {
eval "require $mod";
plan skip_all => "$mod missing for $0" if $@;
@@ -19,7 +19,7 @@ plan skip_all => "$0 must be run from a git working tree" if $?;
# needed for alternates, and --absolute-git-dir is only in git 2.13+
$git_dir = abs_path($git_dir);
-use_ok "PublicInbox::$_" for (qw(Inbox V2Writable MIME Git SolverGit));
+use_ok "PublicInbox::$_" for (qw(Inbox V2Writable MIME Git SolverGit WWW));
my ($inboxdir, $for_destroy) = tmpdir();
my $opts = {
@@ -40,10 +40,10 @@ sub deliver_patch ($) {
}
deliver_patch('t/solve/0001-simple-mod.patch');
-
+my $v1_0_0_tag = 'cb7c42b1e15577ed2215356a2bf925aef59cdd8d';
my $git = PublicInbox::Git->new($git_dir);
is('public-inbox 1.0.0',
- $git->commit_title('cb7c42b1e15577ed2215356a2bf925aef59cdd8d'),
+ $git->commit_title($v1_0_0_tag),
'commit_title works on 1.0.0');
is(undef, $git->commit_title('impossible'), 'undef on impossible object');
@@ -113,4 +113,71 @@ my $hinted = $res;
shift @$res; shift @$hinted;
is_deeply($res, $hinted, 'hints work (or did not hurt :P');
+my @psgi = qw(HTTP::Request::Common Plack::Test URI::Escape Plack::Builder);
+SKIP: {
+ my @missing;
+ for my $mod (@psgi) {
+ eval("require $mod") or push(@missing, $mod);
+ }
+ skip("missing: ".join(', ', @missing), 7 + scalar(@psgi)) if @missing;
+ use_ok($_) for @psgi;
+ my $binfoo = "$inboxdir/binfoo.git";
+ system(qw(git init --bare -q), $binfoo) == 0 or die "git init: $?";
+ require_ok 'PublicInbox::ViewVCS';
+ my $big_size = do {
+ no warnings 'once';
+ $PublicInbox::ViewVCS::MAX_SIZE + 1;
+ };
+ my %bin = (big => $big_size, small => 1);
+ my %oid; # (small|big) => OID
+ my $cmd = [ qw(git hash-object -w --stdin) ];
+ my $env = { GIT_DIR => $binfoo };
+ while (my ($label, $size) = each %bin) {
+ pipe(my ($rout, $wout)) or die;
+ pipe(my ($rin, $win)) or die;
+ my $rdr = { 0 => fileno($rin), 1 => fileno($wout) };
+ my $pid = spawn($cmd , $env, $rdr);
+ $wout = $rin = undef;
+ print { $win } ("\0" x $size) or die;
+ close $win or die;
+ chomp($oid{$label} = <$rout>);
+ }
+
+ # ensure the PSGI frontend (ViewVCS) works:
+ my $name = $ibx->{name};
+ my $cfgpfx = "publicinbox.$name";
+ my $cfg = PublicInbox::Config->new(\<<EOF);
+$cfgpfx.address=$ibx->{address};
+$cfgpfx.inboxdir=$inboxdir
+$cfgpfx.coderepo=public-inbox
+$cfgpfx.coderepo=binfoo
+coderepo.public-inbox.dir=$git_dir
+coderepo.public-inbox.cgiturl=http://example.com/public-inbox
+coderepo.binfoo.dir=$binfoo
+coderepo.binfoo.cgiturl=http://example.com/binfoo
+EOF
+ my $www = PublicInbox::WWW->new($cfg);
+ test_psgi(sub { $www->call(@_) }, sub {
+ my ($cb) = @_;
+ my $res = $cb->(GET("/$name/3435775/s/"));
+ is($res->code, 200, 'success with existing blob');
+
+ $res = $cb->(GET("/$name/".('0'x40).'/s/'));
+ is($res->code, 404, 'failure with null OID');
+
+ $res = $cb->(GET("/$name/$v1_0_0_tag/s/"));
+ is($res->code, 200, 'shows commit');
+ while (my ($label, $size) = each %bin) {
+ $res = $cb->(GET("/$name/$oid{$label}/s/"));
+ is($res->code, 200, "$label binary file");
+ ok(index($res->content, "blob $size bytes") >= 0,
+ "showed $label binary blob size");
+ $res = $cb->(GET("/$name/$oid{$label}/s/raw"));
+ is($res->code, 200, "$label raw binary download");
+ is($res->content, "\0" x $size,
+ "$label content matches");
+ }
+ });
+}
+
done_testing();
^ permalink raw reply related [flat|nested] 10+ messages in thread* [PATCH 3/6] Makefile.PL: sort target and var lists
2019-12-18 3:36 [PATCH 0/6] test updates and speedups Eric Wong
2019-12-18 3:36 ` [PATCH 1/6] TODO: add UUCP address item Eric Wong
2019-12-18 3:36 ` [PATCH 2/6] viewvcs: flesh out some functionality and test Eric Wong
@ 2019-12-18 3:36 ` Eric Wong
2019-12-18 9:05 ` Eric Wong
2019-12-18 3:36 ` [PATCH 4/6] t/*.t: avoid sharing "my" variables in subs Eric Wong
` (2 subsequent siblings)
5 siblings, 1 reply; 10+ messages in thread
From: Eric Wong @ 2019-12-18 3:36 UTC (permalink / raw)
To: meta
Sorting makes it easier to review the generated result.
---
Makefile.PL | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/Makefile.PL b/Makefile.PL
index 3020f25a..33688095 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -83,13 +83,13 @@ $v->{rsync_xdocs} = [ @{$v->{gz_xdocs}}, @{$v->{xdocs_html}}, @{$v->{xdocs}} ];
my $TGTS = join("\n", map {;
my $tgt_prereq = $_;
my $cmds = $t->{$_};
- "$tgt_prereq\n".join('', map { "\t$_\n" } @$cmds);
-} keys %$t);
+ "$tgt_prereq\n".join('', map { "\t$_\n" } sort(@$cmds));
+} sort keys %$t);
my $VARS = join("\n", map {;
my $varname = $_;
- join('', map { "$varname += $_\n" } @{$v->{$varname}});
-} grep(!/^-/, keys %$v));
+ join('', map { "$varname += $_\n" } sort @{$v->{$varname}});
+} grep(!/^-/, sort keys %$v));
# Don't waste user's disk space by installing some pods from
# imported code or internal use only
^ permalink raw reply related [flat|nested] 10+ messages in thread* Re: [PATCH 3/6] Makefile.PL: sort target and var lists
2019-12-18 3:36 ` [PATCH 3/6] Makefile.PL: sort target and var lists Eric Wong
@ 2019-12-18 9:05 ` Eric Wong
0 siblings, 0 replies; 10+ messages in thread
From: Eric Wong @ 2019-12-18 9:05 UTC (permalink / raw)
To: meta
Eric Wong <e@80x24.org> wrote:
> Sorting makes it easier to review the generated result.
> --- a/Makefile.PL
> +++ b/Makefile.PL
> @@ -83,13 +83,13 @@ $v->{rsync_xdocs} = [ @{$v->{gz_xdocs}}, @{$v->{xdocs_html}}, @{$v->{xdocs}} ];
> my $TGTS = join("\n", map {;
> my $tgt_prereq = $_;
> my $cmds = $t->{$_};
> - "$tgt_prereq\n".join('', map { "\t$_\n" } @$cmds);
> -} keys %$t);
> + "$tgt_prereq\n".join('', map { "\t$_\n" } sort(@$cmds));
That sort is very wrong :x ^^^^
Will squash this in before merging.
diff --git a/Makefile.PL b/Makefile.PL
index 0f8e1b74..7ea1ee08 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -83,7 +83,7 @@ $v->{rsync_xdocs} = [ @{$v->{gz_xdocs}}, @{$v->{xdocs_html}}, @{$v->{xdocs}} ];
my $TGTS = join("\n", map {;
my $tgt_prereq = $_;
my $cmds = $t->{$_};
- "$tgt_prereq\n".join('', map { "\t$_\n" } sort(@$cmds));
+ "$tgt_prereq\n".join('', map { "\t$_\n" } @$cmds);
} sort keys %$t);
my $VARS = join("\n", map {;
^ permalink raw reply related [flat|nested] 10+ messages in thread
* [PATCH 4/6] t/*.t: avoid sharing "my" variables in subs
2019-12-18 3:36 [PATCH 0/6] test updates and speedups Eric Wong
` (2 preceding siblings ...)
2019-12-18 3:36 ` [PATCH 3/6] Makefile.PL: sort target and var lists Eric Wong
@ 2019-12-18 3:36 ` Eric Wong
2019-12-18 3:36 ` [PATCH 5/6] tests: move t/common.perl to PublicInbox::TestCommon Eric Wong
2019-12-18 3:36 ` [PATCH 6/6] t/run.perl: to avoid repeated process spawning for *.t Eric Wong
5 siblings, 0 replies; 10+ messages in thread
From: Eric Wong @ 2019-12-18 3:36 UTC (permalink / raw)
To: meta
These usages of file-local global variables make the *.t files
incompatible with run_script(). Instead, use anonymous subs,
"our", or pass the parameter as appropriate.
---
t/httpd-corner.t | 8 ++++----
t/indexlevels-mirror.t | 10 ++++-----
t/mda.t | 46 +++++++++++++++++++++---------------------
t/nntpd-tls.t | 2 +-
t/solver_git.t | 9 +++++----
t/v2mirror.t | 10 ++++-----
t/view.t | 12 +++++------
t/www_listing.t | 4 ++--
8 files changed, 50 insertions(+), 51 deletions(-)
diff --git a/t/httpd-corner.t b/t/httpd-corner.t
index 551af2b2..a8cdb2e9 100644
--- a/t/httpd-corner.t
+++ b/t/httpd-corner.t
@@ -553,16 +553,16 @@ SKIP: {
# filter out pipes inherited from the parent
my @this = `lsof -p $$`;
my $bad;
- sub extract_inodes {
+ my $extract_inodes = sub {
map {;
my @f = split(' ', $_);
my $inode = $f[-2];
$bad = $_ if $inode !~ /\A[0-9]+\z/;
$inode => 1;
} grep (/\bpipe\b/, @_);
- }
- my %child = extract_inodes(@lsof);
- my %parent = extract_inodes(@this);
+ };
+ my %child = $extract_inodes->(@lsof);
+ my %parent = $extract_inodes->(@this);
skip("inode not in expected format: $bad", 1) if defined($bad);
delete @child{(keys %parent)};
is_deeply([], [keys %child], 'no extra pipes with -W0');
diff --git a/t/indexlevels-mirror.t b/t/indexlevels-mirror.t
index 3d4813be..aae42510 100644
--- a/t/indexlevels-mirror.t
+++ b/t/indexlevels-mirror.t
@@ -16,8 +16,6 @@ foreach my $mod (qw(DBD::SQLite)) {
plan skip_all => "$mod missing for $0" if $@;
}
-my @xcpdb = qw(-xcpdb -q);
-
my $mime = PublicInbox::MIME->create(
header => [
From => 'a@example.com',
@@ -29,7 +27,7 @@ my $mime = PublicInbox::MIME->create(
);
sub import_index_incremental {
- my ($v, $level) = @_;
+ my ($v, $level, $mime) = @_;
my $this = "pi-$v-$level-indexlevels";
my ($tmpdir, $for_destroy) = tmpdir();
local $ENV{PI_CONFIG} = "$tmpdir/config";
@@ -120,7 +118,7 @@ sub import_index_incremental {
is_deeply(\@rw_nums, [1], 'unindex NNTP article'.$v.$level);
if ($level ne 'basic') {
- ok(run_script([@xcpdb, $mirror]), "v$v xcpdb OK");
+ ok(run_script(['-xcpdb', '-q', $mirror]), "v$v xcpdb OK");
is(PublicInbox::Admin::detect_indexlevel($ro_mirror), $level,
'indexlevel detectable by Admin after xcpdb v' .$v.$level);
delete $ro_mirror->{$_} for (qw(over search));
@@ -167,13 +165,13 @@ sub import_index_incremental {
}
# we can probably cull some other tests
-import_index_incremental($PI_TEST_VERSION, 'basic');
+import_index_incremental($PI_TEST_VERSION, 'basic', $mime);
SKIP: {
require PublicInbox::Search;
PublicInbox::Search::load_xapian() or skip 'Search::Xapian missing', 2;
foreach my $l (qw(medium full)) {
- import_index_incremental($PI_TEST_VERSION, $l);
+ import_index_incremental($PI_TEST_VERSION, $l, $mime);
}
}
diff --git a/t/mda.t b/t/mda.t
index 47d06132..3686a97b 100644
--- a/t/mda.t
+++ b/t/mda.t
@@ -23,6 +23,23 @@ my $faildir = "$home/faildir/";
my $mime;
my $git = PublicInbox::Git->new($maindir);
+my $fail_bad_header = sub ($$$) {
+ my ($good_rev, $msg, $in) = @_;
+ my @f = glob("$faildir/*/*");
+ unlink @f if @f;
+ my ($out, $err) = ("", "");
+ my $opt = { 0 => \$in, 1 => \$out, 2 => \$err };
+ local $ENV{PATH} = $main_path;
+ ok(run_script(['-mda'], undef, $opt),
+ "no error on undeliverable ($msg)");
+ my $rev = $git->qx(qw(rev-list HEAD));
+ chomp $rev;
+ is($rev, $good_rev, "bad revision not commited ($msg)");
+ @f = glob("$faildir/*/*");
+ is(scalar @f, 1, "faildir written to");
+ [ $in, $out, $err ];
+};
+
{
ok(-x "$main_bin/spamc",
"spamc ham mock found (run in top of source tree");
@@ -110,14 +127,14 @@ EOF
is(scalar @new, 1, "PI_EMERGENCY is written to");
}
- fail_bad_header($good_rev, "bad recipient", <<"");
+ $fail_bad_header->($good_rev, "bad recipient", <<"");
From: Me <me\@example.com>
To: You <you\@example.com>
Message-Id: <bad-recipient\@example.com>
Subject: hihi
Date: Thu, 01 Jan 1970 00:00:00 +0000
- my $fail = fail_bad_header($good_rev, "duplicate Message-ID", <<"");
+ my $fail = $fail_bad_header->($good_rev, "duplicate Message-ID", <<"");
From: Me <me\@example.com>
To: You <you\@example.com>
Cc: $addr
@@ -127,26 +144,26 @@ Date: Thu, 01 Jan 1970 00:00:00 +0000
like($fail->[2], qr/CONFLICT/, "duplicate Message-ID message");
- fail_bad_header($good_rev, "missing From:", <<"");
+ $fail_bad_header->($good_rev, "missing From:", <<"");
To: $addr
Message-ID: <missing-from\@example.com>
Subject: hihi
Date: Thu, 01 Jan 1970 00:00:00 +0000
- fail_bad_header($good_rev, "short subject:", <<"");
+ $fail_bad_header->($good_rev, "short subject:", <<"");
To: $addr
From: cat\@example.com
Message-ID: <short-subject\@example.com>
Subject: a
Date: Thu, 01 Jan 1970 00:00:00 +0000
- fail_bad_header($good_rev, "no date", <<"");
+ $fail_bad_header->($good_rev, "no date", <<"");
To: $addr
From: u\@example.com
Message-ID: <no-date\@example.com>
Subject: hihi
- fail_bad_header($good_rev, "bad date", <<"");
+ $fail_bad_header->($good_rev, "bad date", <<"");
To: $addr
From: u\@example.com
Message-ID: <bad-date\@example.com>
@@ -329,20 +346,3 @@ EOF
}
done_testing();
-
-sub fail_bad_header {
- my ($good_rev, $msg, $in) = @_;
- my @f = glob("$faildir/*/*");
- unlink @f if @f;
- my ($out, $err) = ("", "");
- my $opt = { 0 => \$in, 1 => \$out, 2 => \$err };
- local $ENV{PATH} = $main_path;
- ok(run_script(['-mda'], undef, $opt),
- "no error on undeliverable ($msg)");
- my $rev = $git->qx(qw(rev-list HEAD));
- chomp $rev;
- is($rev, $good_rev, "bad revision not commited ($msg)");
- @f = glob("$faildir/*/*");
- is(scalar @f, 1, "faildir written to");
- [ $in, $out, $err ];
-}
diff --git a/t/nntpd-tls.t b/t/nntpd-tls.t
index bbcc04c0..c6dceaaa 100644
--- a/t/nntpd-tls.t
+++ b/t/nntpd-tls.t
@@ -28,7 +28,7 @@ require './t/common.perl';
require PublicInbox::InboxWritable;
require PublicInbox::MIME;
require PublicInbox::SearchIdx;
-my $need_zlib;
+our $need_zlib;
eval { require Compress::Raw::Zlib } or
$need_zlib = 'Compress::Raw::Zlib missing';
my $version = 2; # v2 needs newer git
diff --git a/t/solver_git.t b/t/solver_git.t
index 6bac17ea..88f83bdb 100644
--- a/t/solver_git.t
+++ b/t/solver_git.t
@@ -32,15 +32,16 @@ my $ibx = PublicInbox::Inbox->new($opts);
my $im = PublicInbox::V2Writable->new($ibx, 1);
$im->{parallel} = 0;
-sub deliver_patch ($) {
+my $deliver_patch = sub ($) {
open my $fh, '<', $_[0] or die "open: $!";
my $mime = PublicInbox::MIME->new(do { local $/; <$fh> });
$im->add($mime);
$im->done;
-}
+};
-deliver_patch('t/solve/0001-simple-mod.patch');
+$deliver_patch->('t/solve/0001-simple-mod.patch');
my $v1_0_0_tag = 'cb7c42b1e15577ed2215356a2bf925aef59cdd8d';
+
my $git = PublicInbox::Git->new($git_dir);
is('public-inbox 1.0.0',
$git->commit_title($v1_0_0_tag),
@@ -96,7 +97,7 @@ $solver = PublicInbox::SolverGit->new($ibx, sub { $res = $_[0] });
$solver->solve($psgi_env, $log, $git_v2_20_1_tag, {});
is($res, undef, 'no error on a tag not in our repo');
-deliver_patch('t/solve/0002-rename-with-modifications.patch');
+$deliver_patch->('t/solve/0002-rename-with-modifications.patch');
$solver = PublicInbox::SolverGit->new($ibx, sub { $res = $_[0] });
$solver->solve($psgi_env, $log, '0a92431', {});
ok($res, 'resolved without hints');
diff --git a/t/v2mirror.t b/t/v2mirror.t
index a45a262e..213a5f15 100644
--- a/t/v2mirror.t
+++ b/t/v2mirror.t
@@ -97,15 +97,15 @@ for my $i (10..15) {
$v2w->done;
$ibx->cleanup;
-sub fetch_each_epoch {
+my $fetch_each_epoch = sub {
foreach my $i (0..$epoch_max) {
my $dir = "$tmpdir/m/git/$i.git";
is(system('git', "--git-dir=$dir", 'fetch', '-q'), 0,
'fetch successful');
}
-}
+};
-fetch_each_epoch();
+$fetch_each_epoch->();
my $mset = $mibx->search->reopen->query('m:15@example.com', {mset => 1});
is(scalar($mset->items), 0, 'new message not found in mirror, yet');
@@ -135,7 +135,7 @@ like($to_purge, qr/\A[a-f0-9]{40,}\z/, 'read blob to be purged');
$mset = $ibx->search->reopen->query('m:10@example.com', {mset => 1});
is(scalar($mset->items), 0, 'purged message gone from origin');
-fetch_each_epoch();
+$fetch_each_epoch->();
{
$ibx->cleanup;
PublicInbox::InboxWritable::cleanup($mibx);
@@ -173,7 +173,7 @@ is($mibx->git->check($to_purge), undef, 'unindex+prune successful in mirror');
ok($v2w->remove($mime), 'removed <1@example.com> from source');
$v2w->done;
$ibx->cleanup;
- fetch_each_epoch();
+ $fetch_each_epoch->();
PublicInbox::InboxWritable::cleanup($mibx);
my $cmd = [ "-index", "$tmpdir/m" ];
diff --git a/t/view.t b/t/view.t
index 1de3a02c..92962b15 100644
--- a/t/view.t
+++ b/t/view.t
@@ -24,8 +24,8 @@ my $ctx = {
};
$ctx->{-inbox}->{-primary_address} = 'test@example.com';
-sub msg_html ($) {
- my ($mime) = @_;
+sub msg_html ($$) {
+ my ($ctx, $mime) = @_;
my $s = '';
my $r = PublicInbox::View::msg_html($ctx, $mime);
@@ -72,7 +72,7 @@ EOF
body => $body,
)->as_string;
my $mime = Email::MIME->new($s);
- my $html = msg_html($mime);
+ my $html = msg_html($ctx, $mime);
# ghetto tests
like($html, qr!<a\nhref="raw"!s, "raw link present");
@@ -102,7 +102,7 @@ EOF
parts => $parts,
);
- my $html = msg_html($mime);
+ my $html = msg_html($ctx, $mime);
like($html, qr/hi\n.*-- Attachment #2.*\nbye\n/s, "multipart split");
}
@@ -131,7 +131,7 @@ EOF
parts => $parts,
);
- my $html = msg_html($mime);
+ my $html = msg_html($ctx, $mime);
like($html, qr!.*Attachment #2: foo&(?:amp|#38);\.patch --!,
"parts split with filename");
}
@@ -157,7 +157,7 @@ EOF
);
my $orig = $mime->body_raw;
- my $html = msg_html($mime);
+ my $html = msg_html($ctx, $mime);
like($orig, qr/hi =3D bye=/, "our test used QP correctly");
like($html, qr/\bhi = bye\b/, "HTML output decoded QP");
}
diff --git a/t/www_listing.t b/t/www_listing.t
index c9201213..e1263360 100644
--- a/t/www_listing.t
+++ b/t/www_listing.t
@@ -33,7 +33,7 @@ like(PublicInbox::WwwListing::fingerprint($bare), qr/\A[a-f0-9]{40}\z/,
'got fingerprint with non-empty repo');
sub tiny_test {
- my ($host, $port) = @_;
+ my ($json, $host, $port) = @_;
my $http = HTTP::Tiny->new;
my $res = $http->get("http://$host:$port/manifest.js.gz");
is($res->{status}, 200, 'got manifest');
@@ -107,7 +107,7 @@ SKIP: {
$td = start_script($cmd, $env, { 3 => $sock });
$sock = undef;
- tiny_test($host, $port);
+ tiny_test($json, $host, $port);
skip 'skipping grok-pull integration test', 2 if !which('grok-pull');
^ permalink raw reply related [flat|nested] 10+ messages in thread* [PATCH 5/6] tests: move t/common.perl to PublicInbox::TestCommon
2019-12-18 3:36 [PATCH 0/6] test updates and speedups Eric Wong
` (3 preceding siblings ...)
2019-12-18 3:36 ` [PATCH 4/6] t/*.t: avoid sharing "my" variables in subs Eric Wong
@ 2019-12-18 3:36 ` Eric Wong
2019-12-19 4:02 ` Eric Wong
2019-12-18 3:36 ` [PATCH 6/6] t/run.perl: to avoid repeated process spawning for *.t Eric Wong
5 siblings, 1 reply; 10+ messages in thread
From: Eric Wong @ 2019-12-18 3:36 UTC (permalink / raw)
To: meta
We want to be able to use run_script with *.t files, so
t/common.perl putting subs into the top-level "main" namespace
won't work. Instead, make it a module which uses Exporter
like other libraries.
---
MANIFEST | 2 +-
t/common.perl => lib/PublicInbox/TestCommon.pm | 16 ++++++++++------
t/admin.t | 2 +-
t/altid.t | 2 +-
t/altid_v2.t | 2 +-
t/cgi.t | 2 +-
t/config.t | 2 +-
t/convert-compact.t | 2 +-
t/edit.t | 2 +-
t/emergency.t | 2 +-
t/feed.t | 2 +-
t/filter_rubylang.t | 2 +-
t/git.t | 2 +-
t/html_index.t | 2 +-
t/httpd-corner.t | 2 +-
t/httpd-https.t | 2 +-
t/httpd-unix.t | 2 +-
t/httpd.t | 2 +-
t/import.t | 2 +-
t/indexlevels-mirror.t | 2 +-
t/init.t | 2 +-
t/mda.t | 2 +-
t/mda_filter_rubylang.t | 2 +-
t/msgmap.t | 2 +-
t/nntpd-tls.t | 2 +-
t/nntpd.t | 2 +-
t/nulsubject.t | 2 +-
t/over.t | 2 +-
t/plack.t | 2 +-
t/psgi_attach.t | 2 +-
t/psgi_bad_mids.t | 2 +-
t/psgi_mount.t | 2 +-
t/psgi_multipart_not.t | 2 +-
t/psgi_scan_all.t | 2 +-
t/psgi_search.t | 2 +-
t/psgi_text.t | 2 +-
t/psgi_v2.t | 2 +-
t/purge.t | 2 +-
t/replace.t | 2 +-
t/search-thr-index.t | 2 +-
t/search.t | 2 +-
t/solver_git.t | 2 +-
t/spamcheck_spamc.t | 2 +-
t/v1-add-remove-add.t | 2 +-
t/v1reindex.t | 2 +-
t/v2-add-remove-add.t | 2 +-
t/v2mda.t | 2 +-
t/v2mirror.t | 2 +-
t/v2reindex.t | 2 +-
t/v2writable.t | 2 +-
t/watch_filter_rubylang.t | 2 +-
t/watch_maildir.t | 2 +-
t/watch_maildir_v2.t | 2 +-
t/www_listing.t | 2 +-
t/xcpdb-reshard.t | 2 +-
xt/git-http-backend.t | 2 +-
xt/nntpd-validate.t | 2 +-
xt/perf-msgview.t | 2 +-
xt/perf-nntpd.t | 2 +-
59 files changed, 68 insertions(+), 64 deletions(-)
rename t/common.perl => lib/PublicInbox/TestCommon.pm (94%)
diff --git a/MANIFEST b/MANIFEST
index 3a301ee7..6bff79ad 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -149,6 +149,7 @@ lib/PublicInbox/Spawn.pm
lib/PublicInbox/SpawnPP.pm
lib/PublicInbox/Syscall.pm
lib/PublicInbox/TLS.pm
+lib/PublicInbox/TestCommon.pm
lib/PublicInbox/Tmpfile.pm
lib/PublicInbox/Unsubscribe.pm
lib/PublicInbox/UserContent.pm
@@ -202,7 +203,6 @@ t/altid.t
t/altid_v2.t
t/cgi.t
t/check-www-inbox.perl
-t/common.perl
t/config.t
t/config_limiter.t
t/content_id.t
diff --git a/t/common.perl b/lib/PublicInbox/TestCommon.pm
similarity index 94%
rename from t/common.perl
rename to lib/PublicInbox/TestCommon.pm
index 288a0a19..2804b5b6 100644
--- a/t/common.perl
+++ b/lib/PublicInbox/TestCommon.pm
@@ -1,11 +1,15 @@
# Copyright (C) 2015-2019 all contributors <meta@public-inbox.org>
# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
+# internal APIs used only for tests
+package PublicInbox::TestCommon;
+use strict;
+use parent qw(Exporter);
use Fcntl qw(FD_CLOEXEC F_SETFD F_GETFD :seek);
use POSIX qw(dup2);
-use strict;
-use warnings;
use IO::Socket::INET;
+our @EXPORT = qw(tmpdir tcp_server tcp_connect require_git
+ run_script start_script key2sub);
sub tmpdir (;$) {
my ($base) = @_;
@@ -49,7 +53,7 @@ sub require_git ($;$) {
my $cur_int = ($cur_maj << 24) | ($cur_min << 16);
if ($cur_int < $req_int) {
return 0 if $maybe;
- plan skip_all => "git $req+ required, have $cur_maj.$cur_min";
+ plan(skip_all => "git $req+ required, have $cur_maj.$cur_min");
}
1;
}
@@ -105,7 +109,7 @@ package $pkg;
use strict;
use subs qw(exit);
-*exit = *::run_script_exit;
+*exit = *PublicInbox::TestCommon::run_script_exit;
sub main {
$str
0;
@@ -244,10 +248,10 @@ sub start_script {
die "FAIL: ",join(' ', $key, @argv), ": $!\n";
}
}
- TestProcess->new($pid, $tail_pid);
+ PublicInboxTestProcess->new($pid, $tail_pid);
}
-package TestProcess;
+package PublicInboxTestProcess;
use strict;
# prevent new threads from inheriting these objects
diff --git a/t/admin.t b/t/admin.t
index 6458982b..b517d2f8 100644
--- a/t/admin.t
+++ b/t/admin.t
@@ -3,7 +3,7 @@
use strict;
use warnings;
use Test::More;
-require './t/common.perl';
+use PublicInbox::TestCommon;
use_ok 'PublicInbox::Admin', qw(resolve_repo_dir);
my ($tmpdir, $for_destroy) = tmpdir();
my $git_dir = "$tmpdir/v1";
diff --git a/t/altid.t b/t/altid.t
index 86e7f9de..fc5bcbc2 100644
--- a/t/altid.t
+++ b/t/altid.t
@@ -3,7 +3,7 @@
use strict;
use warnings;
use Test::More;
-require './t/common.perl';
+use PublicInbox::TestCommon;
foreach my $mod (qw(DBD::SQLite Search::Xapian)) {
eval "require $mod";
plan skip_all => "$mod missing for altid.t" if $@;
diff --git a/t/altid_v2.t b/t/altid_v2.t
index 9e152fc4..5bd62e13 100644
--- a/t/altid_v2.t
+++ b/t/altid_v2.t
@@ -3,7 +3,7 @@
use strict;
use warnings;
use Test::More;
-require './t/common.perl';
+use PublicInbox::TestCommon;
require_git(2.6);
foreach my $mod (qw(DBD::SQLite Search::Xapian)) {
eval "require $mod";
diff --git a/t/cgi.t b/t/cgi.t
index 62cea499..424b738e 100644
--- a/t/cgi.t
+++ b/t/cgi.t
@@ -6,7 +6,7 @@ use strict;
use warnings;
use Test::More;
use Email::MIME;
-require './t/common.perl';
+use PublicInbox::TestCommon;
my ($tmpdir, $for_destroy) = tmpdir();
my $home = "$tmpdir/pi-home";
my $pi_home = "$home/.public-inbox";
diff --git a/t/config.t b/t/config.t
index ade2e796..db3f9b2a 100644
--- a/t/config.t
+++ b/t/config.t
@@ -4,7 +4,7 @@ use strict;
use warnings;
use Test::More;
use PublicInbox::Config;
-require './t/common.perl';
+use PublicInbox::TestCommon;
my ($tmpdir, $for_destroy) = tmpdir();
{
diff --git a/t/convert-compact.t b/t/convert-compact.t
index b8dc5ed5..c6da64ea 100644
--- a/t/convert-compact.t
+++ b/t/convert-compact.t
@@ -5,7 +5,7 @@ use warnings;
use Test::More;
use PublicInbox::MIME;
use PublicInbox::Spawn qw(which);
-require './t/common.perl';
+use PublicInbox::TestCommon;
require_git(2.6);
my @mods = qw(DBD::SQLite Search::Xapian);
foreach my $mod (@mods) {
diff --git a/t/edit.t b/t/edit.t
index 122aa19f..9a78b45d 100644
--- a/t/edit.t
+++ b/t/edit.t
@@ -4,7 +4,7 @@
use strict;
use warnings;
use Test::More;
-require './t/common.perl';
+use PublicInbox::TestCommon;
require_git(2.6);
require PublicInbox::Inbox;
require PublicInbox::InboxWritable;
diff --git a/t/emergency.t b/t/emergency.t
index d6c7b6d5..1cb1098d 100644
--- a/t/emergency.t
+++ b/t/emergency.t
@@ -3,7 +3,7 @@
use strict;
use warnings;
use Test::More;
-require './t/common.perl';
+use PublicInbox::TestCommon;
my ($tmpdir, $for_destroy) = tmpdir();
use_ok 'PublicInbox::Emergency';
diff --git a/t/feed.t b/t/feed.t
index daf97a72..97468c73 100644
--- a/t/feed.t
+++ b/t/feed.t
@@ -10,7 +10,7 @@ use PublicInbox::Import;
use PublicInbox::Config;
use PublicInbox::Inbox;
my $have_xml_feed = eval { require XML::Feed; 1 };
-require './t/common.perl';
+use PublicInbox::TestCommon;
sub string_feed {
my $res = PublicInbox::Feed::generate($_[0]);
diff --git a/t/filter_rubylang.t b/t/filter_rubylang.t
index 33753925..576cbdeb 100644
--- a/t/filter_rubylang.t
+++ b/t/filter_rubylang.t
@@ -4,7 +4,7 @@ use strict;
use warnings;
use Test::More;
use Email::MIME;
-require './t/common.perl';
+use PublicInbox::TestCommon;
use_ok 'PublicInbox::Filter::RubyLang';
my $f = PublicInbox::Filter::RubyLang->new;
diff --git a/t/git.t b/t/git.t
index cc4fc591..d4694f44 100644
--- a/t/git.t
+++ b/t/git.t
@@ -3,7 +3,7 @@
use strict;
use warnings;
use Test::More;
-require './t/common.perl';
+use PublicInbox::TestCommon;
my ($dir, $for_destroy) = tmpdir();
use PublicInbox::Spawn qw(popen_rd);
diff --git a/t/html_index.t b/t/html_index.t
index 51ea9a25..55aa6dc7 100644
--- a/t/html_index.t
+++ b/t/html_index.t
@@ -8,7 +8,7 @@ use PublicInbox::Feed;
use PublicInbox::Git;
use PublicInbox::Import;
use PublicInbox::Inbox;
-require './t/common.perl';
+use PublicInbox::TestCommon;
my ($tmpdir, $for_destroy) = tmpdir();
my $git_dir = "$tmpdir/gittest";
my $ibx = PublicInbox::Inbox->new({
diff --git a/t/httpd-corner.t b/t/httpd-corner.t
index a8cdb2e9..fb3ffcf1 100644
--- a/t/httpd-corner.t
+++ b/t/httpd-corner.t
@@ -19,7 +19,7 @@ use IO::Socket::UNIX;
use Fcntl qw(:seek);
use Socket qw(IPPROTO_TCP TCP_NODELAY SOL_SOCKET);
use POSIX qw(mkfifo);
-require './t/common.perl';
+use PublicInbox::TestCommon;
my ($tmpdir, $for_destroy) = tmpdir();
my $fifo = "$tmpdir/fifo";
ok(defined mkfifo($fifo, 0777), 'created FIFO');
diff --git a/t/httpd-https.t b/t/httpd-https.t
index de74c20e..1d2e4d5c 100644
--- a/t/httpd-https.t
+++ b/t/httpd-https.t
@@ -17,7 +17,7 @@ unless (-r $key && -r $cert) {
}
use_ok 'PublicInbox::TLS';
use_ok 'IO::Socket::SSL';
-require './t/common.perl';
+use PublicInbox::TestCommon;
my $psgi = "./t/httpd-corner.psgi";
my ($tmpdir, $for_destroy) = tmpdir();
my $err = "$tmpdir/stderr.log";
diff --git a/t/httpd-unix.t b/t/httpd-unix.t
index 2c8f8d6b..bd4ee12e 100644
--- a/t/httpd-unix.t
+++ b/t/httpd-unix.t
@@ -4,7 +4,7 @@
use strict;
use warnings;
use Test::More;
-require './t/common.perl';
+use PublicInbox::TestCommon;
use Errno qw(EADDRINUSE);
foreach my $mod (qw(Plack::Util Plack::Builder HTTP::Date HTTP::Status)) {
diff --git a/t/httpd.t b/t/httpd.t
index f0b4efb4..517329fb 100644
--- a/t/httpd.t
+++ b/t/httpd.t
@@ -9,7 +9,7 @@ foreach my $mod (qw(Plack::Util Plack::Builder HTTP::Date HTTP::Status)) {
plan skip_all => "$mod missing for httpd.t" if $@;
}
use Socket qw(IPPROTO_TCP SOL_SOCKET);
-require './t/common.perl';
+use PublicInbox::TestCommon;
# FIXME: too much setup
my ($tmpdir, $for_destroy) = tmpdir();
diff --git a/t/import.t b/t/import.t
index 2f5b08a5..3cf7e2d2 100644
--- a/t/import.t
+++ b/t/import.t
@@ -10,7 +10,7 @@ use PublicInbox::Spawn qw(spawn);
use IO::File;
use Fcntl qw(:DEFAULT);
use File::Temp qw/tempfile/;
-require './t/common.perl';
+use PublicInbox::TestCommon;
my ($dir, $for_destroy) = tmpdir();
is(system(qw(git init -q --bare), $dir), 0, 'git init successful');
diff --git a/t/indexlevels-mirror.t b/t/indexlevels-mirror.t
index aae42510..876abd2c 100644
--- a/t/indexlevels-mirror.t
+++ b/t/indexlevels-mirror.t
@@ -7,7 +7,7 @@ use PublicInbox::MIME;
use PublicInbox::Inbox;
use PublicInbox::InboxWritable;
require PublicInbox::Admin;
-require './t/common.perl';
+use PublicInbox::TestCommon;
my $PI_TEST_VERSION = $ENV{PI_TEST_VERSION} || 2;
require_git('2.6') if $PI_TEST_VERSION == 2;
diff --git a/t/init.t b/t/init.t
index 16550868..f70d1c20 100644
--- a/t/init.t
+++ b/t/init.t
@@ -4,7 +4,7 @@ use strict;
use warnings;
use Test::More;
use PublicInbox::Config;
-require './t/common.perl';
+use PublicInbox::TestCommon;
use File::Basename;
my ($tmpdir, $for_destroy) = tmpdir();
sub quiet_fail {
diff --git a/t/mda.t b/t/mda.t
index 3686a97b..4556e323 100644
--- a/t/mda.t
+++ b/t/mda.t
@@ -7,7 +7,7 @@ use Email::MIME;
use Cwd qw(getcwd);
use PublicInbox::MID qw(mid2path);
use PublicInbox::Git;
-require './t/common.perl';
+use PublicInbox::TestCommon;
my ($tmpdir, $for_destroy) = tmpdir();
my $home = "$tmpdir/pi-home";
my $pi_home = "$home/.public-inbox";
diff --git a/t/mda_filter_rubylang.t b/t/mda_filter_rubylang.t
index ce17d5a9..a5b6af3c 100644
--- a/t/mda_filter_rubylang.t
+++ b/t/mda_filter_rubylang.t
@@ -5,7 +5,7 @@ use warnings;
use Test::More;
use PublicInbox::MIME;
use PublicInbox::Config;
-require './t/common.perl';
+use PublicInbox::TestCommon;
require_git(2.6);
my @mods = qw(DBD::SQLite Search::Xapian);
foreach my $mod (@mods) {
diff --git a/t/msgmap.t b/t/msgmap.t
index 7fcd131a..6edeed56 100644
--- a/t/msgmap.t
+++ b/t/msgmap.t
@@ -3,7 +3,7 @@
use strict;
use warnings;
use Test::More;
-require './t/common.perl';
+use PublicInbox::TestCommon;
foreach my $mod (qw(DBD::SQLite)) {
eval "require $mod";
diff --git a/t/nntpd-tls.t b/t/nntpd-tls.t
index c6dceaaa..25b7bd1c 100644
--- a/t/nntpd-tls.t
+++ b/t/nntpd-tls.t
@@ -24,7 +24,7 @@ unless (-r $key && -r $cert) {
use_ok 'PublicInbox::TLS';
use_ok 'IO::Socket::SSL';
-require './t/common.perl';
+use PublicInbox::TestCommon;
require PublicInbox::InboxWritable;
require PublicInbox::MIME;
require PublicInbox::SearchIdx;
diff --git a/t/nntpd.t b/t/nntpd.t
index 5b697344..30f3fb9c 100644
--- a/t/nntpd.t
+++ b/t/nntpd.t
@@ -15,7 +15,7 @@ use IO::Socket;
use Socket qw(IPPROTO_TCP TCP_NODELAY);
use Net::NNTP;
use Sys::Hostname;
-require './t/common.perl';
+use PublicInbox::TestCommon;
# FIXME: make easier to test both versions
my $version = $ENV{PI_TEST_VERSION} || 2;
diff --git a/t/nulsubject.t b/t/nulsubject.t
index 617997c0..45f95a9e 100644
--- a/t/nulsubject.t
+++ b/t/nulsubject.t
@@ -3,7 +3,7 @@
use strict;
use warnings;
use Test::More;
-require './t/common.perl';
+use PublicInbox::TestCommon;
use_ok 'PublicInbox::Import';
use_ok 'PublicInbox::Git';
diff --git a/t/over.t b/t/over.t
index 27168a33..5e33a0b0 100644
--- a/t/over.t
+++ b/t/over.t
@@ -4,7 +4,7 @@ use strict;
use warnings;
use Test::More;
use Compress::Zlib qw(compress);
-require './t/common.perl';
+use PublicInbox::TestCommon;
foreach my $mod (qw(DBD::SQLite)) {
eval "require $mod";
plan skip_all => "$mod missing for over.t" if $@;
diff --git a/t/plack.t b/t/plack.t
index 6023a419..c9a2cf79 100644
--- a/t/plack.t
+++ b/t/plack.t
@@ -4,7 +4,7 @@ use strict;
use warnings;
use Test::More;
use Email::MIME;
-require './t/common.perl';
+use PublicInbox::TestCommon;
my $psgi = "./examples/public-inbox.psgi";
my ($tmpdir, $for_destroy) = tmpdir();
my $pi_config = "$tmpdir/config";
diff --git a/t/psgi_attach.t b/t/psgi_attach.t
index 45f05bac..5a7129f9 100644
--- a/t/psgi_attach.t
+++ b/t/psgi_attach.t
@@ -4,7 +4,7 @@ use strict;
use warnings;
use Test::More;
use Email::MIME;
-require './t/common.perl';
+use PublicInbox::TestCommon;
my ($tmpdir, $for_destroy) = tmpdir();
my $maindir = "$tmpdir/main.git";
my $addr = 'test-public@example.com';
diff --git a/t/psgi_bad_mids.t b/t/psgi_bad_mids.t
index 0e8fa114..b22f3652 100644
--- a/t/psgi_bad_mids.t
+++ b/t/psgi_bad_mids.t
@@ -6,7 +6,7 @@ use Test::More;
use PublicInbox::MIME;
use PublicInbox::Config;
use PublicInbox::WWW;
-require './t/common.perl';
+use PublicInbox::TestCommon;
my @mods = qw(DBD::SQLite HTTP::Request::Common Plack::Test
URI::Escape Plack::Builder);
foreach my $mod (@mods) {
diff --git a/t/psgi_mount.t b/t/psgi_mount.t
index ca573e1e..a2621a2a 100644
--- a/t/psgi_mount.t
+++ b/t/psgi_mount.t
@@ -4,7 +4,7 @@ use strict;
use warnings;
use Test::More;
use Email::MIME;
-require './t/common.perl';
+use PublicInbox::TestCommon;
my ($tmpdir, $for_destroy) = tmpdir();
my $maindir = "$tmpdir/main.git";
my $addr = 'test-public@example.com';
diff --git a/t/psgi_multipart_not.t b/t/psgi_multipart_not.t
index d3489f2d..9384d14a 100644
--- a/t/psgi_multipart_not.t
+++ b/t/psgi_multipart_not.t
@@ -6,7 +6,7 @@ use Test::More;
use Email::MIME;
use PublicInbox::Config;
use PublicInbox::WWW;
-require './t/common.perl';
+use PublicInbox::TestCommon;
my @mods = qw(DBD::SQLite Search::Xapian HTTP::Request::Common
Plack::Test URI::Escape Plack::Builder Plack::Test);
foreach my $mod (@mods) {
diff --git a/t/psgi_scan_all.t b/t/psgi_scan_all.t
index 5d4cc263..fa636d32 100644
--- a/t/psgi_scan_all.t
+++ b/t/psgi_scan_all.t
@@ -5,7 +5,7 @@ use warnings;
use Test::More;
use Email::MIME;
use PublicInbox::Config;
-require './t/common.perl';
+use PublicInbox::TestCommon;
my @mods = qw(HTTP::Request::Common Plack::Test URI::Escape DBD::SQLite);
foreach my $mod (@mods) {
eval "require $mod";
diff --git a/t/psgi_search.t b/t/psgi_search.t
index 0c430aea..d1050437 100644
--- a/t/psgi_search.t
+++ b/t/psgi_search.t
@@ -9,7 +9,7 @@ use PublicInbox::Inbox;
use PublicInbox::InboxWritable;
use PublicInbox::WWW;
use bytes (); # only for bytes::length
-require './t/common.perl';
+use PublicInbox::TestCommon;
my @mods = qw(DBD::SQLite Search::Xapian HTTP::Request::Common Plack::Test
URI::Escape Plack::Builder);
foreach my $mod (@mods) {
diff --git a/t/psgi_text.t b/t/psgi_text.t
index b9564181..ee4d9f14 100644
--- a/t/psgi_text.t
+++ b/t/psgi_text.t
@@ -4,7 +4,7 @@ use strict;
use warnings;
use Test::More;
use Email::MIME;
-require './t/common.perl';
+use PublicInbox::TestCommon;
my ($tmpdir, $for_destroy) = tmpdir();
my $maindir = "$tmpdir/main.git";
my $addr = 'test-public@example.com';
diff --git a/t/psgi_v2.t b/t/psgi_v2.t
index 1163e2bf..8e81e89b 100644
--- a/t/psgi_v2.t
+++ b/t/psgi_v2.t
@@ -3,7 +3,7 @@
use strict;
use warnings;
use Test::More;
-require './t/common.perl';
+use PublicInbox::TestCommon;
require_git(2.6);
use PublicInbox::MIME;
use PublicInbox::Config;
diff --git a/t/purge.t b/t/purge.t
index db09b731..0262f791 100644
--- a/t/purge.t
+++ b/t/purge.t
@@ -3,7 +3,7 @@
use strict;
use warnings;
use Test::More;
-require './t/common.perl';
+use PublicInbox::TestCommon;
require_git(2.6);
my @mods = qw(DBI DBD::SQLite);
foreach my $mod (@mods) {
diff --git a/t/replace.t b/t/replace.t
index 57290f96..2346c3a1 100644
--- a/t/replace.t
+++ b/t/replace.t
@@ -5,7 +5,7 @@ use warnings;
use Test::More;
use PublicInbox::MIME;
use PublicInbox::InboxWritable;
-require './t/common.perl';
+use PublicInbox::TestCommon;
use Cwd qw(abs_path);
require_git(2.6); # replace is v2 only, for now...
foreach my $mod (qw(DBD::SQLite)) {
diff --git a/t/search-thr-index.t b/t/search-thr-index.t
index 4f793657..47454fe7 100644
--- a/t/search-thr-index.t
+++ b/t/search-thr-index.t
@@ -13,7 +13,7 @@ foreach my $mod (@mods) {
}
require PublicInbox::SearchIdx;
require PublicInbox::Inbox;
-require './t/common.perl';
+use PublicInbox::TestCommon;
my ($tmpdir, $for_destroy) = tmpdir();
my $git_dir = "$tmpdir/a.git";
diff --git a/t/search.t b/t/search.t
index 58684138..33a7596e 100644
--- a/t/search.t
+++ b/t/search.t
@@ -10,7 +10,7 @@ foreach my $mod (@mods) {
};
require PublicInbox::SearchIdx;
require PublicInbox::Inbox;
-require './t/common.perl';
+use PublicInbox::TestCommon;
use Email::MIME;
my ($tmpdir, $for_destroy) = tmpdir();
my $git_dir = "$tmpdir/a.git";
diff --git a/t/solver_git.t b/t/solver_git.t
index 88f83bdb..99ee9b5e 100644
--- a/t/solver_git.t
+++ b/t/solver_git.t
@@ -4,7 +4,7 @@ use strict;
use warnings;
use Test::More;
use Cwd qw(abs_path);
-require './t/common.perl';
+use PublicInbox::TestCommon;
require_git(2.6);
use PublicInbox::Spawn qw(spawn);
diff --git a/t/spamcheck_spamc.t b/t/spamcheck_spamc.t
index a4a01a8b..92b4fd40 100644
--- a/t/spamcheck_spamc.t
+++ b/t/spamcheck_spamc.t
@@ -6,7 +6,7 @@ use Test::More;
use Email::Simple;
use IO::File;
use Fcntl qw(:DEFAULT SEEK_SET);
-require './t/common.perl';
+use PublicInbox::TestCommon;
my ($tmpdir, $for_destroy) = tmpdir();
use_ok 'PublicInbox::Spamcheck::Spamc';
diff --git a/t/v1-add-remove-add.t b/t/v1-add-remove-add.t
index 13e9f29c..aabb2fa5 100644
--- a/t/v1-add-remove-add.t
+++ b/t/v1-add-remove-add.t
@@ -5,7 +5,7 @@ use warnings;
use Test::More;
use PublicInbox::MIME;
use PublicInbox::Import;
-require './t/common.perl';
+use PublicInbox::TestCommon;
foreach my $mod (qw(DBD::SQLite Search::Xapian)) {
eval "require $mod";
diff --git a/t/v1reindex.t b/t/v1reindex.t
index c0e21a56..321b3b21 100644
--- a/t/v1reindex.t
+++ b/t/v1reindex.t
@@ -6,7 +6,7 @@ use Test::More;
use PublicInbox::MIME;
use PublicInbox::ContentId qw(content_digest);
use File::Path qw(remove_tree);
-require './t/common.perl';
+use PublicInbox::TestCommon;
require_git(2.6);
foreach my $mod (qw(DBD::SQLite Search::Xapian)) {
diff --git a/t/v2-add-remove-add.t b/t/v2-add-remove-add.t
index c0dec300..7cce2493 100644
--- a/t/v2-add-remove-add.t
+++ b/t/v2-add-remove-add.t
@@ -4,7 +4,7 @@ use strict;
use warnings;
use Test::More;
use PublicInbox::MIME;
-require './t/common.perl';
+use PublicInbox::TestCommon;
require_git(2.6);
foreach my $mod (qw(DBD::SQLite Search::Xapian)) {
diff --git a/t/v2mda.t b/t/v2mda.t
index 11a517e4..4b1249ea 100644
--- a/t/v2mda.t
+++ b/t/v2mda.t
@@ -6,7 +6,7 @@ use Test::More;
use PublicInbox::MIME;
use Fcntl qw(SEEK_SET);
use Cwd;
-require './t/common.perl';
+use PublicInbox::TestCommon;
require_git(2.6);
my $V = 2;
diff --git a/t/v2mirror.t b/t/v2mirror.t
index 213a5f15..e3c384fa 100644
--- a/t/v2mirror.t
+++ b/t/v2mirror.t
@@ -3,7 +3,7 @@
use strict;
use warnings;
use Test::More;
-require './t/common.perl';
+use PublicInbox::TestCommon;
use Cwd qw(abs_path);
require_git(2.6);
local $ENV{HOME} = abs_path('t');
diff --git a/t/v2reindex.t b/t/v2reindex.t
index e222d0f1..a14bf798 100644
--- a/t/v2reindex.t
+++ b/t/v2reindex.t
@@ -6,7 +6,7 @@ use Test::More;
use PublicInbox::MIME;
use PublicInbox::ContentId qw(content_digest);
use File::Path qw(remove_tree);
-require './t/common.perl';
+use PublicInbox::TestCommon;
require_git(2.6);
foreach my $mod (qw(DBD::SQLite Search::Xapian)) {
diff --git a/t/v2writable.t b/t/v2writable.t
index 8bbcd45a..bf2064d0 100644
--- a/t/v2writable.t
+++ b/t/v2writable.t
@@ -5,7 +5,7 @@ use warnings;
use Test::More;
use PublicInbox::MIME;
use PublicInbox::ContentId qw(content_digest);
-require './t/common.perl';
+use PublicInbox::TestCommon;
use Cwd qw(abs_path);
require_git(2.6);
foreach my $mod (qw(DBD::SQLite Search::Xapian)) {
diff --git a/t/watch_filter_rubylang.t b/t/watch_filter_rubylang.t
index c4078879..0ea680ee 100644
--- a/t/watch_filter_rubylang.t
+++ b/t/watch_filter_rubylang.t
@@ -2,7 +2,7 @@
# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
use strict;
use warnings;
-require './t/common.perl';
+use PublicInbox::TestCommon;
use Test::More;
use PublicInbox::MIME;
use PublicInbox::Config;
diff --git a/t/watch_maildir.t b/t/watch_maildir.t
index d2e6fecd..38297043 100644
--- a/t/watch_maildir.t
+++ b/t/watch_maildir.t
@@ -5,7 +5,7 @@ use Test::More;
use Email::MIME;
use Cwd;
use PublicInbox::Config;
-require './t/common.perl';
+use PublicInbox::TestCommon;
my @mods = qw(Filesys::Notify::Simple);
foreach my $mod (@mods) {
eval "require $mod";
diff --git a/t/watch_maildir_v2.t b/t/watch_maildir_v2.t
index 53f1bdfc..77e4b981 100644
--- a/t/watch_maildir_v2.t
+++ b/t/watch_maildir_v2.t
@@ -5,7 +5,7 @@ use Test::More;
use PublicInbox::MIME;
use Cwd;
use PublicInbox::Config;
-require './t/common.perl';
+use PublicInbox::TestCommon;
require_git(2.6);
my @mods = qw(Search::Xapian DBD::SQLite Filesys::Notify::Simple);
foreach my $mod (@mods) {
diff --git a/t/www_listing.t b/t/www_listing.t
index e1263360..75698ee5 100644
--- a/t/www_listing.t
+++ b/t/www_listing.t
@@ -5,7 +5,7 @@ use strict;
use warnings;
use Test::More;
use PublicInbox::Spawn qw(which);
-require './t/common.perl';
+use PublicInbox::TestCommon;
my @mods = qw(URI::Escape Plack::Builder Digest::SHA
IO::Compress::Gzip IO::Uncompress::Gunzip HTTP::Tiny);
foreach my $mod (@mods) {
diff --git a/t/xcpdb-reshard.t b/t/xcpdb-reshard.t
index a4ab35d6..0d78d2b2 100644
--- a/t/xcpdb-reshard.t
+++ b/t/xcpdb-reshard.t
@@ -8,7 +8,7 @@ foreach my $mod (@mods) {
eval "require $mod";
plan skip_all => "missing $mod for $0" if $@;
};
-require './t/common.perl';
+use PublicInbox::TestCommon;
require_git('2.6');
use PublicInbox::MIME;
use PublicInbox::InboxWritable;
diff --git a/xt/git-http-backend.t b/xt/git-http-backend.t
index a927d89e..5f96369f 100644
--- a/xt/git-http-backend.t
+++ b/xt/git-http-backend.t
@@ -7,7 +7,7 @@ use strict;
use warnings;
use Test::More;
use POSIX qw(setsid);
-require './t/common.perl';
+use PublicInbox::TestCommon;
my $git_dir = $ENV{GIANT_GIT_DIR};
plan 'skip_all' => 'GIANT_GIT_DIR not defined' unless $git_dir;
diff --git a/xt/nntpd-validate.t b/xt/nntpd-validate.t
index 39108639..c82d46e2 100644
--- a/xt/nntpd-validate.t
+++ b/xt/nntpd-validate.t
@@ -29,7 +29,7 @@ my $key = 'certs/server-key.pem';
if ($test_tls && !-r $key || !-r $cert) {
plan skip_all => "certs/ missing for $0, run $^X ./certs/create-certs.perl";
}
-require './t/common.perl';
+use PublicInbox::TestCommon;
my ($tmpdir, $ftd) = tmpdir();
$File::Temp::KEEP_ALL = !!$ENV{TEST_KEEP_TMP};
my (%OPT, $td, $host_port, $group);
diff --git a/xt/perf-msgview.t b/xt/perf-msgview.t
index 22d8ce20..11bd3a5d 100644
--- a/xt/perf-msgview.t
+++ b/xt/perf-msgview.t
@@ -6,7 +6,7 @@ use Test::More;
use Benchmark qw(:all);
use PublicInbox::Inbox;
use PublicInbox::View;
-require './t/common.perl';
+use PublicInbox::TestCommon;
my $inboxdir = $ENV{GIANT_INBOX_DIR} // $ENV{GIANT_PI_DIR};
plan skip_all => "GIANT_INBOX_DIR not defined for $0" unless $inboxdir;
diff --git a/xt/perf-nntpd.t b/xt/perf-nntpd.t
index 5a176e08..df5ecb41 100644
--- a/xt/perf-nntpd.t
+++ b/xt/perf-nntpd.t
@@ -10,7 +10,7 @@ my $inboxdir = $ENV{GIANT_INBOX_DIR} // $ENV{GIANT_PI_DIR};
plan skip_all => "GIANT_INBOX_DIR not defined for $0" unless defined($inboxdir);
eval { require PublicInbox::Search };
my ($host_port, $group, %opts, $s, $td, $tmp_obj);
-require './t/common.perl';
+use PublicInbox::TestCommon;
if (($ENV{NNTP_TEST_URL} || '') =~ m!\Anntp://([^/]+)/([^/]+)\z!) {
($host_port, $group) = ($1, $2);
^ permalink raw reply related [flat|nested] 10+ messages in thread* Re: [PATCH 5/6] tests: move t/common.perl to PublicInbox::TestCommon
2019-12-18 3:36 ` [PATCH 5/6] tests: move t/common.perl to PublicInbox::TestCommon Eric Wong
@ 2019-12-19 4:02 ` Eric Wong
0 siblings, 0 replies; 10+ messages in thread
From: Eric Wong @ 2019-12-19 4:02 UTC (permalink / raw)
To: meta
Eric Wong <e@80x24.org> wrote:
> diff --git a/t/common.perl b/lib/PublicInbox/TestCommon.pm
> similarity index 94%
> rename from t/common.perl
> rename to lib/PublicInbox/TestCommon.pm
> index 288a0a19..2804b5b6 100644
> --- a/t/common.perl
> +++ b/lib/PublicInbox/TestCommon.pm
> @@ -1,11 +1,15 @@
> # Copyright (C) 2015-2019 all contributors <meta@public-inbox.org>
> # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
>
> +# internal APIs used only for tests
> +package PublicInbox::TestCommon;
Oops, forgot to account for the namespace change in the uncommon
tail(1) support code path. Will squash the following:
diff --git a/lib/PublicInbox/TestCommon.pm b/lib/PublicInbox/TestCommon.pm
index 2804b5b6..45306a5a 100644
--- a/lib/PublicInbox/TestCommon.pm
+++ b/lib/PublicInbox/TestCommon.pm
@@ -279,7 +279,7 @@ sub DESTROY {
my ($self) = @_;
return if $self->{owner} != $$;
if (my $tail = delete $self->{tail_pid}) {
- ::wait_for_tail();
+ PublicInbox::TestCommon::wait_for_tail();
CORE::kill('TERM', $tail);
}
my $pid = delete $self->{pid} or return;
^ permalink raw reply related [flat|nested] 10+ messages in thread
* [PATCH 6/6] t/run.perl: to avoid repeated process spawning for *.t
2019-12-18 3:36 [PATCH 0/6] test updates and speedups Eric Wong
` (4 preceding siblings ...)
2019-12-18 3:36 ` [PATCH 5/6] tests: move t/common.perl to PublicInbox::TestCommon Eric Wong
@ 2019-12-18 3:36 ` Eric Wong
2019-12-19 4:03 ` Eric Wong
5 siblings, 1 reply; 10+ messages in thread
From: Eric Wong @ 2019-12-18 3:36 UTC (permalink / raw)
To: meta
Spawning a new Perl interpreter for every test case
means Perl has to reparse and recompile every single file
it needs, costing us performance and development time.
Now that we've modified our code to avoid global state,
we can preload everything we need.
The new "check-run" test target is now 20-30% faster
than the original "check" target.
---
.gitignore | 1 +
MANIFEST | 1 +
Makefile.PL | 12 ++-
lib/PublicInbox/TestCommon.pm | 12 ++-
t/nntpd.t | 3 +
t/run.perl | 182 ++++++++++++++++++++++++++++++++++
6 files changed, 205 insertions(+), 6 deletions(-)
create mode 100755 t/run.perl
diff --git a/.gitignore b/.gitignore
index bdb8cf15..7f4142ba 100644
--- a/.gitignore
+++ b/.gitignore
@@ -19,3 +19,4 @@
/NEWS.html
/NEWS.atom
/NEWS
+*.log
diff --git a/MANIFEST b/MANIFEST
index 6bff79ad..997b6e88 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -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 33688095..70eb94c1 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 2804b5b6..d6ed0876 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;
}
diff --git a/t/nntpd.t b/t/nntpd.t
index 30f3fb9c..c3712b67 100644
--- a/t/nntpd.t
+++ b/t/nntpd.t
@@ -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..15d1f7e0
--- /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 shouldnot 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;
^ permalink raw reply related [flat|nested] 10+ messages in thread