diff options
Diffstat (limited to 'lib/PublicInbox/TestCommon.pm')
| -rw-r--r-- | lib/PublicInbox/TestCommon.pm | 613 |
1 files changed, 449 insertions, 164 deletions
diff --git a/lib/PublicInbox/TestCommon.pm b/lib/PublicInbox/TestCommon.pm index aff34853..a7ec9b5b 100644 --- a/lib/PublicInbox/TestCommon.pm +++ b/lib/PublicInbox/TestCommon.pm @@ -1,4 +1,4 @@ -# Copyright (C) 2015-2021 all contributors <meta@public-inbox.org> +# Copyright (C) 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 @@ -6,19 +6,31 @@ package PublicInbox::TestCommon; use strict; use parent qw(Exporter); use v5.10.1; -use Fcntl qw(FD_CLOEXEC F_SETFD F_GETFD :seek); +use Fcntl qw(F_SETFD F_GETFD FD_CLOEXEC :seek); use POSIX qw(dup2); use IO::Socket::INET; use File::Spec; +use Scalar::Util qw(isvstring); +use Carp (); our @EXPORT; my $lei_loud = $ENV{TEST_LEI_ERR_LOUD}; -our ($lei_opt, $lei_out, $lei_err, $lei_cwdfh); +our $tail_cmd = $ENV{TAIL}; +our ($lei_opt, $lei_out, $lei_err); +use autodie qw(chdir close fcntl mkdir open opendir seek unlink); + +$_ = File::Spec->rel2abs($_) for (grep(!m!^/!, @INC)); + BEGIN { @EXPORT = qw(tmpdir tcp_server tcp_connect require_git require_mods run_script start_script key2sub xsys xsys_e xqx eml_load tick have_xapian_compact json_utf8 setup_public_inboxes create_inbox + create_dir + create_coderepo require_bsd kernel_version check_broken_tmpfs + quit_waiter_pipe wait_for_eof require_git_http_backend tcp_host_port test_lei lei lei_ok $lei_out $lei_err $lei_opt - test_httpd xbail require_cmd is_xdeeply); + test_httpd xbail require_cmd is_xdeeply tail_f + ignore_inline_c_missing no_pollerfd no_coredump cfg_new + strace strace_inject lsof_pid oct_is); require Test::More; my @methods = grep(!/\W/, @Test::More::EXPORT); eval(join('', map { "*$_=\\&Test::More::$_;" } @methods)); @@ -26,23 +38,56 @@ BEGIN { push @EXPORT, @methods; } +sub kernel_version () { + state $version = do { + require POSIX; + my @u = POSIX::uname(); + if ($u[2] =~ /\A([0-9]+(?:\.[0-9]+)+)/) { + eval "v$1"; + } else { + local $" = "', `"; + diag "Unable to get kernel version from: `@u'"; + undef; + } + }; +} + +sub check_broken_tmpfs () { + return if $^O ne 'dragonfly' || kernel_version ge v6.5; + diag 'EVFILT_VNODE + tmpfs is broken on dragonfly <= 6.4 (have: '. + sprintf('%vd', kernel_version).')'; + 1; +} + +sub require_bsd (;$) { + state $ok = ($^O =~ m!\A(?:free|net|open)bsd\z! || + $^O eq 'dragonfly'); + return 1 if $ok; + return if defined(wantarray); + my $m = "$0 is BSD-only (\$^O=$^O)"; + @_ ? skip($m, 1) : plan(skip_all => $m); +} + sub xbail (@) { BAIL_OUT join(' ', map { ref() ? (explain($_)) : ($_) } @_) } +sub read_all ($;$$$) { + require PublicInbox::IO; + PublicInbox::IO::read_all($_[0], $_[1], $_[2], $_[3]) +} + sub eml_load ($) { my ($path, $cb) = @_; - open(my $fh, '<', $path) or die "open $path: $!"; + open(my $fh, '<', $path); require PublicInbox::Eml; - PublicInbox::Eml->new(\(do { local $/; <$fh> })); + PublicInbox::Eml->new(\(scalar read_all $fh)); } sub tmpdir (;$) { my ($base) = @_; require File::Temp; - unless (defined $base) { - ($base) = ($0 =~ m!\b([^/]+)\.[^\.]+\z!); - } + ($base) = ($0 =~ m!\b([^/]+)\.[^\.]+\z!) unless defined $base; my $tmpdir = File::Temp->newdir("pi-$base-$$-XXXX", TMPDIR => 1); - ($tmpdir->dirname, $tmpdir); + wantarray ? ($tmpdir->dirname, $tmpdir) : $tmpdir; } sub tcp_server () { @@ -55,8 +100,12 @@ sub tcp_server () { ); eval { die 'IPv4-only' if $ENV{TEST_IPV4_ONLY}; - require IO::Socket::INET6; - IO::Socket::INET6->new(%opt, LocalAddr => '[::1]') + my $pkg; + for (qw(IO::Socket::IP IO::Socket::INET6)) { + eval "require $_" or next; + $pkg = $_ and last; + } + $pkg->new(%opt, LocalAddr => '[::1]'); } || eval { die 'IPv6-only' if $ENV{TEST_IPV6_ONLY}; IO::Socket::INET->new(%opt, LocalAddr => '127.0.0.1') @@ -88,31 +137,65 @@ sub tcp_connect { } sub require_cmd ($;$) { - my ($cmd, $maybe) = @_; + my ($cmd, $nr) = @_; require PublicInbox::Spawn; - my $bin = PublicInbox::Spawn::which($cmd); + state %CACHE; + my $bin = $CACHE{$cmd} //= PublicInbox::Spawn::which($cmd); return $bin if $bin; - $maybe ? 0 : plan(skip_all => "$cmd missing from PATH for $0"); + return plan(skip_all => "$cmd missing from PATH for $0") if !$nr; + defined(wantarray) ? undef : skip("$cmd missing", $nr); } -sub have_xapian_compact () { - require_cmd($ENV{XAPIAN_COMPACT} || 'xapian-compact', 1); +sub have_xapian_compact (;$) { + require_cmd($ENV{XAPIAN_COMPACT} || 'xapian-compact', @_ ? $_[0] : ()); } sub require_git ($;$) { - my ($req, $maybe) = @_; - my ($req_maj, $req_min, $req_sub) = split(/\./, $req); - my ($cur_maj, $cur_min, $cur_sub) = (xqx([qw(git --version)]) - =~ /version (\d+)\.(\d+)(?:\.(\d+))?/); - - my $req_int = ($req_maj << 24) | ($req_min << 16) | ($req_sub // 0); - my $cur_int = ($cur_maj << 24) | ($cur_min << 16) | ($cur_sub // 0); - if ($cur_int < $req_int) { - return 0 if $maybe; - plan skip_all => - "git $req+ required, have $cur_maj.$cur_min.$cur_sub"; + my ($req, $nr) = @_; + require PublicInbox::Git; + state $cur_vstr = PublicInbox::Git::git_version(); + $req = eval("v$req") unless isvstring($req); + + return 1 if $cur_vstr ge $req; + state $cur_ver = sprintf('%vd', $cur_vstr); + return plan skip_all => "git $req+ required, have $cur_ver" if !$nr; + defined(wantarray) ? undef : + skip("git $req+ required (have $cur_ver)", $nr) +} + +sub require_git_http_backend (;$) { + my ($nr) = @_; + state $ok = do { + require PublicInbox::Git; + my $git = PublicInbox::Git::check_git_exe() or plan + skip_all => 'nothing in public-inbox works w/o git'; + my $rdr = { 1 => \my $out, 2 => \my $err }; + xsys([$git, qw(http-backend)], undef, $rdr); + $out =~ /^Status:/ism; + }; + if (!$ok) { + my $msg = "`git http-backend' not available"; + defined($nr) ? skip $msg, $nr : plan skip_all => $msg; } - 1; + $ok; +} + +my %IPv6_VERSION = ( + 'Net::NNTP' => 3.00, + 'Mail::IMAPClient' => 3.40, + 'HTTP::Tiny' => 0.042, + 'Net::POP3' => 2.32, +); + +sub need_accept_filter ($) { + my ($af) = @_; + return if $^O eq 'netbsd'; # since NetBSD 5.0, no kldstat needed + $^O =~ /\A(?:freebsd|dragonfly)\z/ or + skip 'SO_ACCEPTFILTER is FreeBSD/NetBSD/Dragonfly-only so far', + 1; + state $tried = {}; + ($tried->{$af} //= system("kldstat -m $af >/dev/null")) and + skip "$af not loaded: kldload $af", 1; } sub require_mods { @@ -122,7 +205,7 @@ sub require_mods { while (my $mod = shift(@mods)) { if ($mod eq 'lei') { require_git(2.6, $maybe ? $maybe : ()); - push @mods, qw(DBD::SQLite Search::Xapian); + push @mods, qw(DBD::SQLite Xapian +SCM_RIGHTS); $mod = 'json'; # fall-through } if ($mod eq 'json') { @@ -131,18 +214,30 @@ sub require_mods { push @mods, qw(Plack::Builder Plack::Util); next; } elsif ($mod eq '-imapd') { - push @mods, qw(Parse::RecDescent DBD::SQLite - Email::Address::XS||Mail::Address); + push @mods, qw(Parse::RecDescent DBD::SQLite); next; - } elsif ($mod eq '-nntpd') { + } elsif ($mod eq '-nntpd' || $mod eq 'v2') { push @mods, qw(DBD::SQLite); next; } - if ($mod eq 'Search::Xapian') { + if ($mod eq 'Xapian') { if (eval { require PublicInbox::Search } && PublicInbox::Search::load_xapian()) { next; } + } elsif ($mod eq '+SCM_RIGHTS') { + if (my $msg = need_scm_rights()) { + push @need, $msg; + next; + } + } elsif ($mod eq ':fcntl_lock') { + next if $^O eq 'linux' || require_bsd; + diag "untested platform: $^O, ". + "requiring File::FcntlLock..."; + push @mods, 'File::FcntlLock'; + } elsif ($mod =~ /\A\+(accf_.*)\z/) { + need_accept_filter($1); + next } elsif (index($mod, '||') >= 0) { # "Foo||Bar" my $ok; for my $m (split(/\Q||\E/, $mod)) { @@ -165,9 +260,13 @@ sub require_mods { !eval{ IO::Socket::SSL->VERSION(2.007); 1 }) { push @need, $@; } + if (defined(my $v = $IPv6_VERSION{$mod})) { + $ENV{TEST_IPV4_ONLY} = 1 if !eval { $mod->VERSION($v) }; + } } return unless @need; my $m = join(', ', @need)." missing for $0"; + $m =~ s/\bEmail::MIME\b/Email::MIME (development purposes only)/; skip($m, $maybe) if $maybe; plan(skip_all => $m) } @@ -190,9 +289,9 @@ sub _prepare_redirects ($) { for (my $fd = 0; $fd <= $#io_mode; $fd++) { my $fh = $fhref->[$fd] or next; my ($oldfh, $mode) = @{$io_mode[$fd]}; - open my $orig, $mode, $oldfh or die "$oldfh $mode stash: $!"; + open(my $orig, $mode, $oldfh); $orig_io->[$fd] = $orig; - open $oldfh, $mode, $fh or die "$oldfh $mode redirect: $!"; + open $oldfh, $mode, $fh; } $orig_io; } @@ -202,7 +301,7 @@ sub _undo_redirects ($) { for (my $fd = 0; $fd <= $#io_mode; $fd++) { my $fh = $orig_io->[$fd] or next; my ($oldfh, $mode) = @{$io_mode[$fd]}; - open $oldfh, $mode, $fh or die "$$oldfh $mode redirect: $!"; + open $oldfh, $mode, $fh; } } @@ -228,8 +327,8 @@ sub key2sub ($) { my ($key) = @_; $cached_scripts{$key} //= do { my $f = key2script($key); - open my $fh, '<', $f or die "open $f: $!"; - my $str = do { local $/; <$fh> }; + open my $fh, '<', $f; + my $str = read_all($fh); my $pkg = (split(m!/!, $f))[-1]; $pkg =~ s/([a-z])([a-z0-9]+)(\.t)?\z/\U$1\E$2/; $pkg .= "_T" if $3; @@ -244,7 +343,7 @@ use subs qw(exit); sub main { # the below "line" directive is a magic comment, see perlsyn(1) manpage # line 1 "$f" -$str +{ $str } 0; } 1; @@ -273,31 +372,67 @@ sub _run_sub ($$$) { } } +sub no_coredump (@) { + my @dirs = @_; + my $cwdfh; + opendir($cwdfh, '.') if @dirs; + my @found; + for (@dirs, '.') { + chdir $_; + my @cores = glob('core.* *.core'); + push @cores, 'core' if -d 'core'; + push(@found, "@cores found in $_") if @cores; + chdir $cwdfh if $cwdfh; + } + return if !@found; # keep it quiet. + is(scalar(@found), 0, 'no core dumps found'); + diag(join("\n", @found) . Carp::longmess()); + if (-t STDIN) { + diag 'press ENTER to continue, (q) to quit'; + chomp(my $line = <STDIN>); + xbail 'user quit' if $line =~ /\Aq/; + } +} + sub run_script ($;$$) { my ($cmd, $env, $opt) = @_; + no_coredump($opt->{-C} ? ($opt->{-C}) : ()); my ($key, @argv) = @$cmd; my $run_mode = $ENV{TEST_RUN_MODE} // $opt->{run_mode} // 1; my $sub = $run_mode == 0 ? undef : key2sub($key); my $fhref = []; my $spawn_opt = {}; + my @tail_paths; + local $tail_cmd = $tail_cmd; for my $fd (0..2) { my $redir = $opt->{$fd}; my $ref = ref($redir); if ($ref eq 'SCALAR') { - open my $fh, '+>', undef or die "open: $!"; + my $fh; + if ($ENV{TAIL_ALL} && $fd > 0) { + # tail -F is better, but not portable :< + $tail_cmd //= 'tail -f'; + require File::Temp; + $fh = File::Temp->new("fd.$fd-XXXX", TMPDIR=>1); + push @tail_paths, $fh->filename; + } else { + open $fh, '+>', undef; + } + $fh or xbail $!; $fhref->[$fd] = $fh; $spawn_opt->{$fd} = $fh; next if $fd > 0; $fh->autoflush(1); print $fh $$redir or die "print: $!"; - seek($fh, 0, SEEK_SET) or die "seek: $!"; + seek($fh, 0, SEEK_SET); } elsif ($ref eq 'GLOB') { $spawn_opt->{$fd} = $fhref->[$fd] = $redir; } elsif ($ref) { die "unable to deal with $ref $redir"; } } - if ($key =~ /-(index|convert|extindex|convert|xcpdb)\z/) { + my $tail = @tail_paths ? tail_f(@tail_paths, $opt) : undef; + if ($key =~ /-(index|cindex|extindex|convert|xcpdb)\z/) { unshift @argv, '--no-fsync'; } if ($run_mode == 0) { @@ -308,11 +443,7 @@ sub run_script ($;$$) { $cmd->[0] = File::Spec->rel2abs($cmd->[0]); $spawn_opt->{'-C'} = $d; } - my $pid = PublicInbox::Spawn::spawn($cmd, $env, $spawn_opt); - if (defined $pid) { - my $r = waitpid($pid, 0) // die "waitpid: $!"; - $r == $pid or die "waitpid: expected $pid, got $r"; - } + PublicInbox::Spawn::run_wait($cmd, $env, $spawn_opt); } else { # localize and run everything in the same process: # note: "local *STDIN = *STDIN;" and so forth did not work in # old versions of perl @@ -322,30 +453,26 @@ sub run_script ($;$$) { local $SIG{FPE} = 'IGNORE'; # Perl default local $0 = join(' ', @$cmd); my $orig_io = _prepare_redirects($fhref); - my $cwdfh = $lei_cwdfh; - if (my $d = $opt->{'-C'}) { - unless ($cwdfh) { - opendir $cwdfh, '.' or die "opendir .: $!"; - } - chdir $d or die "chdir $d: $!"; - } + opendir(my $cwdfh, '.'); + chdir $opt->{-C} if defined $opt->{-C}; _run_sub($sub, $key, \@argv); - eval { PublicInbox::Inbox::cleanup_task() }; - die "fchdir(restore): $!" if $cwdfh && !chdir($cwdfh); + # n.b. all our uses of PublicInbox::DS should be fine + # with this and we can't Reset here. + chdir($cwdfh); _undo_redirects($orig_io); select STDOUT; umask($umask); } + { local $?; undef $tail }; # slurp the redirects back into user-supplied strings for my $fd (1..2) { my $fh = $fhref->[$fd] or next; next unless -f $fh; - seek($fh, 0, SEEK_SET) or die "seek: $!"; - my $redir = $opt->{$fd}; - local $/; - $$redir = <$fh>; + seek($fh, 0, SEEK_SET); + ${$opt->{$fd}} = read_all($fh); } + no_coredump($opt->{-C} ? ($opt->{-C}) : ()); $? == 0; } @@ -355,17 +482,17 @@ sub tick (;$) { 1; } -sub wait_for_tail ($;$) { +sub wait_for_tail { my ($tail_pid, $want) = @_; - my $wait = 2; + my $wait = 2; # "tail -F" sleeps 1.0s at-a-time w/o inotify/kevent if ($^O eq 'linux') { # GNU tail may use inotify state $tail_has_inotify; - return tick if $want < 0 && $tail_has_inotify; - my $end = time + $wait; + return tick if !$want && $tail_has_inotify; # before TERM + my $end = time + $wait; # wait for startup: my @ino; do { @ino = grep { - readlink($_) =~ /\binotify\b/ + (readlink($_) // '') =~ /\binotify\b/ } glob("/proc/$tail_pid/fd/*"); } while (!@ino && time <= $end and tick); return if !@ino; @@ -373,7 +500,7 @@ sub wait_for_tail ($;$) { $ino[0] =~ s!/fd/!/fdinfo/!; my @info; do { - if (open my $fh, '<', $ino[0]) { + if (CORE::open(my $fh, '<', $ino[0])) { local $/ = "\n"; @info = grep(/^inotify wd:/, <$fh>); } @@ -410,13 +537,35 @@ sub xqx { wantarray ? split(/^/m, $out) : $out; } +sub tail_f (@) { + my @f = grep(defined, @_); + $tail_cmd or return; # "tail -F" or "tail -f" + my $opt = (ref($f[-1]) eq 'HASH') ? pop(@f) : {}; + my $clofork = $opt->{-CLOFORK} // []; + my @cfmap = map { + my $fl = fcntl($_, F_GETFD, 0); + fcntl($_, F_SETFD, $fl | FD_CLOEXEC) unless $fl & FD_CLOEXEC; + ($_, $fl); + } @$clofork; + for (@f) { open(my $fh, '>>', $_) }; + my $cmd = [ split(/ /, $tail_cmd), @f ]; + require PublicInbox::Spawn; + my $pid = PublicInbox::Spawn::spawn($cmd, undef, { 1 => 2 }); + while (my ($io, $fl) = splice(@cfmap, 0, 2)) { + fcntl($io, F_SETFD, $fl); + } + wait_for_tail($pid, scalar @f); + require PublicInbox::AutoReap; + PublicInbox::AutoReap->new($pid, \&wait_for_tail); +} + sub start_script { my ($cmd, $env, $opt) = @_; my ($key, @argv) = @$cmd; my $run_mode = $ENV{TEST_RUN_MODE} // $opt->{run_mode} // 2; my $sub = $run_mode == 0 ? undef : key2sub($key); - my $tail_pid; - if (my $tail_cmd = $ENV{TAIL}) { + my $tail; + if ($tail_cmd) { my @paths; for (@argv) { next unless /\A--std(?:err|out)=(.+)\z/; @@ -434,34 +583,27 @@ sub start_script { } } } - if (@paths) { - $tail_pid = fork // die "fork: $!"; - if ($tail_pid == 0) { - # make sure files exist, first - open my $fh, '>>', $_ for @paths; - open(STDOUT, '>&STDERR') or die "1>&2: $!"; - exec(split(' ', $tail_cmd), @paths); - die "$tail_cmd failed: $!"; - } - wait_for_tail($tail_pid, scalar @paths); - } + $tail = tail_f(@paths, $opt); } - my $pid = fork // die "fork: $!\n"; + require PublicInbox::DS; + my $oset = PublicInbox::DS::block_signals(); + require PublicInbox::OnDestroy; + my $tmp_mask = PublicInbox::OnDestroy::all( + \&PublicInbox::DS::sig_setmask, $oset); + my $pid = PublicInbox::DS::fork_persist(); if ($pid == 0) { - eval { PublicInbox::DS->Reset }; + close($_) for (@{delete($opt->{-CLOFORK}) // []}); # pretend to be systemd (cf. sd_listen_fds(3)) # 3 == SD_LISTEN_FDS_START my $fd; - for ($fd = 0; 1; $fd++) { - my $s = $opt->{$fd}; - last if $fd >= 3 && !defined($s); - next unless $s; - my $fl = fcntl($s, F_GETFD, 0); - if (($fl & FD_CLOEXEC) != FD_CLOEXEC) { - warn "got FD:".fileno($s)." w/o CLOEXEC\n"; + for ($fd = 0; $fd < 3 || defined($opt->{$fd}); $fd++) { + my $io = $opt->{$fd} // next; + my $old = fileno($io); + if ($old == $fd) { + fcntl($io, F_SETFD, 0); + } else { + dup2($old, $fd) // die "dup2($old, $fd): $!"; } - fcntl($s, F_SETFD, $fl &= ~FD_CLOEXEC); - dup2(fileno($s), $fd) or die "dup2 failed: $!\n"; } %ENV = (%ENV, %$env) if $env; my $fds = $fd - 3; @@ -469,9 +611,12 @@ sub start_script { $ENV{LISTEN_PID} = $$; $ENV{LISTEN_FDS} = $fds; } + if ($opt->{-C}) { chdir($opt->{-C}) } $0 = join(' ', @$cmd); + local @SIG{keys %SIG} = map { undef } values %SIG; + local $SIG{FPE} = 'IGNORE'; # Perl default + undef $tmp_mask; if ($sub) { - eval { PublicInbox::DS->Reset }; _run_sub($sub, $key, \@argv); POSIX::_exit($? >> 8); } else { @@ -479,7 +624,11 @@ sub start_script { die "FAIL: ",join(' ', $key, @argv), ": $!\n"; } } - PublicInboxTestProcess->new($pid, $tail_pid); + undef $tmp_mask; + require PublicInbox::AutoReap; + my $td = PublicInbox::AutoReap->new($pid); + $td->{-extra} = $tail; + $td; } # favor lei() or lei_ok() over $lei for new code @@ -510,7 +659,7 @@ sub lei_ok (@) { my @msg = ref($_[0]) eq 'ARRAY' ? @{$_[0]} : @_; if (!$lei_loud) { for (@msg) { - s!\A([a-z0-9]+://)[^/]+/!$1\$HOST_PORT/!; + s!(127\.0\.0\.1|\[::1\]):(?:\d+)!$1:\$PORT!g; s!$tmpdir\b/(?:[^/]+/)?!\$TMPDIR/!g; s!\Q$PWD\E\b!\$PWD!g; } @@ -530,57 +679,86 @@ sub is_xdeeply ($$$) { $ok; } +sub ignore_inline_c_missing { + $_[0] = join('', grep(/\S/, grep(!/compilation aborted/, + grep(!/\bInline\b/, split(/^/m, $_[0]))))); +} + +sub need_scm_rights () { + state $ok = PublicInbox::Spawn->can('send_cmd4') || do { + require PublicInbox::Syscall; + PublicInbox::Syscall->can('send_cmd4'); # Linux only + } || eval { require Socket::MsgHdr; 1 }; + return if $ok; + 'need SCM_RIGHTS support: Inline::C unconfigured/missing '. + '(mkdir -p ~/.cache/public-inbox/inline-c) OR Socket::MsgHdr missing'; +} + +# returns a pipe with FD_CLOEXEC disabled on the write-end +sub quit_waiter_pipe () { + pipe(my $r, my $w); + fcntl($w, F_SETFD, fcntl($w, F_GETFD, 0) & ~FD_CLOEXEC); + ($r, $w); +} + +sub wait_for_eof ($$;$) { + my ($io, $msg, $sec) = @_; + vec(my $rset = '', fileno($io), 1) = 1; + ok(select($rset, undef, undef, $sec // 9), "$msg (select)"); + is(my $line = <$io>, undef, "$msg EOF"); +} + sub test_lei { SKIP: { my ($cb) = pop @_; my $test_opt = shift // {}; - local $lei_cwdfh; - opendir $lei_cwdfh, '.' or xbail "opendir .: $!"; - require_git(2.6, 1) or skip('git 2.6+ required for lei test', 2); + require_git(2.6, 1); my $mods = $test_opt->{mods} // [ 'lei' ]; require_mods(@$mods, 2); + + # set PERL_INLINE_DIRECTORY before clobbering XDG_CACHE_HOME + require PublicInbox::Spawn; require PublicInbox::Config; require File::Path; + local %ENV = %ENV; delete $ENV{XDG_DATA_HOME}; delete $ENV{XDG_CONFIG_HOME}; + delete $ENV{XDG_CACHE_HOME}; $ENV{GIT_COMMITTER_EMAIL} = 'lei@example.com'; $ENV{GIT_COMMITTER_NAME} = 'lei user'; + $ENV{LANG} = $ENV{LC_ALL} = 'C'; my (undef, $fn, $lineno) = caller(0); my $t = "$fn:$lineno"; - require PublicInbox::Spawn; - state $lei_daemon = PublicInbox::Spawn->can('send_cmd4') || - eval { require Socket::MsgHdr; 1 }; - unless ($lei_daemon) { - skip('Inline::C unconfigured/missing '. -'(mkdir -p ~/.cache/public-inbox/inline-c) OR Socket::MsgHdr missing', - 1); - } $lei_opt = { 1 => \$lei_out, 2 => \$lei_err }; my ($daemon_pid, $for_destroy, $daemon_xrd); my $tmpdir = $test_opt->{tmpdir}; - File::Path::mkpath($tmpdir) if (defined $tmpdir && !-d $tmpdir); + File::Path::mkpath($tmpdir) if defined $tmpdir; ($tmpdir, $for_destroy) = tmpdir unless $tmpdir; + my ($dead_r, $dead_w); state $persist_xrd = $ENV{TEST_LEI_DAEMON_PERSIST_DIR}; SKIP: { $ENV{TEST_LEI_ONESHOT} and xbail 'TEST_LEI_ONESHOT no longer supported'; my $home = "$tmpdir/lei-daemon"; - mkdir($home, 0700) or BAIL_OUT "mkdir: $!"; + mkdir($home, 0700); local $ENV{HOME} = $home; my $persist; if ($persist_xrd && !$test_opt->{daemon_only}) { $persist = $daemon_xrd = $persist_xrd; } else { $daemon_xrd = "$home/xdg_run"; - mkdir($daemon_xrd, 0700) or BAIL_OUT "mkdir: $!"; + mkdir($daemon_xrd, 0700); + ($dead_r, $dead_w) = quit_waiter_pipe; } local $ENV{XDG_RUNTIME_DIR} = $daemon_xrd; - $cb->(); + $cb->(); # likely shares $dead_w with lei-daemon + undef $dead_w; # so select() wakes up when daemon dies if ($persist) { # remove before ~/.local gets removed File::Path::rmtree([glob("$home/*")]); File::Path::rmtree("$home/.config"); } else { + no_coredump $tmpdir; lei_ok(qw(daemon-pid), \"daemon-pid after $t"); chomp($daemon_pid = $lei_out); if (!$daemon_pid) { @@ -592,13 +770,10 @@ SKIP: { } }; # SKIP for lei_daemon if ($daemon_pid) { - for (0..10) { - kill(0, $daemon_pid) or last; - tick; - } - ok(!kill(0, $daemon_pid), "$t daemon stopped"); + wait_for_eof($dead_r, 'daemon quit pipe'); + no_coredump $tmpdir; my $f = "$daemon_xrd/lei/errors.log"; - open my $fh, '<', $f or BAIL_OUT "$f: $!"; + open my $fh, '<', $f; my @l = <$fh>; is_xdeeply(\@l, [], "$t daemon XDG_RUNTIME_DIR/lei/errors.log empty"); @@ -616,8 +791,7 @@ sub setup_public_inboxes () { return @ret if -f $stamp; require PublicInbox::Lock; - my $lk = bless { lock_path => "$test_home/setup.lock" }, - 'PublicInbox::Lock'; + my $lk = PublicInbox::Lock->new("$test_home/setup.lock"); my $end = $lk->lock_for_scope; return @ret if -f $stamp; @@ -627,7 +801,7 @@ sub setup_public_inboxes () { '--newsgroup', "t.v$V", "t$V", "$test_home/t$V", "http://example.com/t$V", "t$V\@example.com" ]) or xbail "init v$V"; - unlink "$test_home/t$V/description" or xbail "unlink $!"; + unlink "$test_home/t$V/description"; } require PublicInbox::Config; require PublicInbox::InboxWritable; @@ -647,24 +821,76 @@ sub setup_public_inboxes () { $im->done; }); $seen or BAIL_OUT 'no imports'; - open my $fh, '>', $stamp or BAIL_OUT "open $stamp: $!"; + open my $fh, '>', $stamp; @ret; } -sub create_inbox ($$;@) { +our %COMMIT_ENV = ( + GIT_AUTHOR_NAME => 'A U Thor', + GIT_COMMITTER_NAME => 'C O Mitter', + GIT_AUTHOR_EMAIL => 'a@example.com', + GIT_COMMITTER_EMAIL => 'c@example.com', +); + +# for memoizing based on coderefs and various create_* params +sub my_sum { + require PublicInbox::SHA; + require Data::Dumper; + my $d = Data::Dumper->new(\@_); + $d->$_(1) for qw(Deparse Sortkeys Terse); + my @l = split /\n/s, $d->Dump; + @l = grep !/\$\^H\{.+?[A-Z]+\(0x[0-9a-f]+\)/, @l; # autodie addresses + my @addr = grep /[A-Za-z]+\(0x[0-9a-f]+\)/, @l; + xbail 'undumpable addresses: ', \@addr if @addr; + substr PublicInbox::SHA::sha256_hex(join('', @l)), 0, 8; +} + +sub create_dir (@) { + my ($ident, $cb) = (shift, pop); + my %opt = @_; + require PublicInbox::Lock; + require PublicInbox::Import; + my $tmpdir = delete $opt{tmpdir}; + my ($base) = ($0 =~ m!\b([^/]+)\.[^\.]+\z!); + my $dir = "t/data-gen/$base.$ident-".my_sum($cb, \%opt); + require File::Path; + my $new = File::Path::make_path($dir); + my $lk = PublicInbox::Lock->new("$dir/creat.lock"); + my $scope = $lk->lock_for_scope; + if (!-f "$dir/creat.stamp") { + opendir(my $cwd, '.'); + chdir($dir); + local %ENV = (%ENV, %COMMIT_ENV); + $cb->($dir); + chdir($cwd); # some $cb chdir around + open my $s, '>', "$dir/creat.stamp"; + } + return $dir if !defined($tmpdir); + xsys_e([qw(/bin/cp -Rp), $dir, $tmpdir]); + $tmpdir; +} + +sub create_coderepo (@) { + my $ident = shift; + require PublicInbox::Import; + my ($db) = (PublicInbox::Import::default_branch() =~ m!([^/]+)\z!); + create_dir "$ident-$db", @_; +} + +sub create_inbox ($;@) { my $ident = shift; my $cb = pop; my %opt = @_; require PublicInbox::Lock; require PublicInbox::InboxWritable; + require PublicInbox::Import; my ($base) = ($0 =~ m!\b([^/]+)\.[^\.]+\z!); - my $dir = "t/data-gen/$base.$ident"; - my $new = !-d $dir; - if ($new) { - mkdir $dir; # may race - -d $dir or BAIL_OUT "$dir could not be created: $!"; - } - my $lk = bless { lock_path => "$dir/creat.lock" }, 'PublicInbox::Lock'; + my ($db) = (PublicInbox::Import::default_branch() =~ m!([^/]+)\z!); + my $tmpdir = delete $opt{tmpdir}; + my $dir = "t/data-gen/$base.$ident-".my_sum($db, $cb, \%opt); + require File::Path; + my $new = File::Path::make_path($dir); + my $lk = PublicInbox::Lock->new("$dir/creat.lock"); $opt{inboxdir} = File::Spec->rel2abs($dir); $opt{name} //= $ident; my $scope = $lk->lock_for_scope; @@ -672,7 +898,6 @@ sub create_inbox ($$;@) { $pre_cb->($dir) if $pre_cb && $new; $opt{-no_fsync} = 1; my $no_gc = delete $opt{-no_gc}; - my $tmpdir = delete $opt{tmpdir}; my $addr = $opt{address} // []; $opt{-primary_address} //= $addr->[0] // "$ident\@example.com"; my $parallel = delete($opt{importer_parallel}) // 0; @@ -689,8 +914,7 @@ sub create_inbox ($$;@) { xsys_e([ qw(git gc -q) ], { GIT_DIR => $dir }); } } - open my $s, '>', "$dir/creat.stamp" or - BAIL_OUT "error creating $dir/creat.stamp: $!"; + open my $s, '>', "$dir/creat.stamp"; } if ($tmpdir) { undef $ibx; @@ -702,23 +926,31 @@ sub create_inbox ($$;@) { $ibx; } -sub test_httpd ($$;$) { - my ($env, $client, $skip) = @_; - for (qw(PI_CONFIG TMPDIR)) { - $env->{$_} or BAIL_OUT "$_ unset"; - } +sub test_httpd ($$;$$) { + my ($env, $client, $skip, $cb) = @_; + my ($tmpdir, $for_destroy); + $env->{TMPDIR} //= do { + ($tmpdir, $for_destroy) = tmpdir(); + $tmpdir; + }; + for (qw(PI_CONFIG)) { $env->{$_} or BAIL_OUT "$_ unset" } SKIP: { - require_mods(qw(Plack::Test::ExternalServer), $skip // 1); + require_mods(qw(Plack::Test::ExternalServer LWP::UserAgent), + $skip // 1); my $sock = tcp_server() or die; my ($out, $err) = map { "$env->{TMPDIR}/std$_.log" } qw(out err); my $cmd = [ qw(-httpd -W0), "--stdout=$out", "--stderr=$err" ]; my $td = start_script($cmd, $env, { 3 => $sock }); my ($h, $p) = tcp_host_port($sock); local $ENV{PLACK_TEST_EXTERNALSERVER_URI} = "http://$h:$p"; - Plack::Test::ExternalServer::test_psgi(client => $client); + my $ua = LWP::UserAgent->new; + $ua->max_redirect(0); + Plack::Test::ExternalServer::test_psgi(client => $client, + ua => $ua); + $cb->() if $cb; $td->join('TERM'); - open my $fh, '<', $err or BAIL_OUT $!; - my $e = do { local $/; <$fh> }; + open my $fh, '<', $err; + my $e = read_all($fh); if ($e =~ s/^Plack::Middleware::ReverseProxy missing,\n//gms) { $e =~ s/^URL generation for redirects .*\n//gms; } @@ -726,39 +958,92 @@ sub test_httpd ($$;$) { } }; +# TODO: support fstat(1) on OpenBSD, lsof already works on FreeBSD + Linux +# don't use this for deleted file checks, we only check that on Linux atm +# and we can readlink /proc/PID/fd/* directly +sub lsof_pid ($;$) { + my ($pid, $rdr) = @_; + state $lsof = require_cmd('lsof', 1); + $lsof or skip 'lsof missing/broken', 1; + my @out = xqx([$lsof, '-p', $pid], undef, $rdr); + if ($?) { + undef $lsof; + skip "lsof -p PID broken \$?=$?", 1; + } + my @cols = split ' ', $out[0]; + if (($cols[7] // '') eq 'NODE') { # normal lsof + @out; + } else { # busybox lsof ignores -p, so we DIY it + grep /\b$pid\b/, @out; + } +} -package PublicInboxTestProcess; -use strict; - -# prevent new threads from inheriting these objects -sub CLONE_SKIP { 1 } +sub no_pollerfd ($) { + my ($pid) = @_; + my ($re, @cmd); + $^O eq 'linux' and + ($re, @cmd) = (qr/\Q[eventpoll]\E/, qw(lsof -p), $pid); + # n.b. *BSDs uses kqueue to emulate signalfd and/or inotify, + # and we can't distinguish which is which easily. + SKIP: { + (@cmd && $re) or + skip 'open poller test is Linux-only', 1; + my $bin = require_cmd($cmd[0], 1) or skip "$cmd[0] missing", 1; + $cmd[0] = $bin; + my @of = xqx(\@cmd, {}, {2 => \(my $e)}); + my $err = $?; + skip "$bin broken? (\$?=$err) ($e)", 1 if $err; + @of = grep /\b$pid\b/, @of; # busybox lsof ignores -p + is(grep(/$re/, @of), 0, "no $re FDs") or diag explain(\@of); + } +} -sub new { - my ($klass, $pid, $tail_pid) = @_; - bless { pid => $pid, tail_pid => $tail_pid, owner => $$ }, $klass; +sub cfg_new ($;@) { + my ($tmpdir, @body) = @_; + require PublicInbox::Config; + my $f = "$tmpdir/tmp_cfg"; + open my $fh, '>', $f; + print $fh @body; + close $fh; + PublicInbox::Config->new($f); } -sub kill { - my ($self, $sig) = @_; - CORE::kill($sig // 'TERM', $self->{pid}); +our $strace_cmd; +sub strace (@) { + my ($for_daemon) = @_; + skip 'linux only test', 1 if $^O ne 'linux'; + if ($for_daemon) { + my $f = '/proc/sys/kernel/yama/ptrace_scope'; + # TODO: we could fiddle with prctl in the daemon to make + # things work, but I'm not sure it's worth it... + state $ps = do { + my $fh; + CORE::open($fh, '<', $f) ? readline($fh) : 0; + }; + chomp $ps; + skip "strace unusable on daemons\n$f is `$ps' (!= 0)", 1 if $ps; + } + require_cmd('strace', 1) or skip 'strace not available', 1; } -sub join { - my ($self, $sig) = @_; - my $pid = delete $self->{pid} or return; - CORE::kill($sig, $pid) if defined $sig; - my $ret = waitpid($pid, 0) // die "waitpid($pid): $!"; - $ret == $pid or die "waitpid($pid) != $ret"; +sub strace_inject (;$) { + my $cmd = strace(@_); + state $ver = do { + require PublicInbox::Spawn; + my $v = PublicInbox::Spawn::run_qx([$cmd, '-V']); + $v =~ m!version\s+([1-9]+\.[0-9]+)! or + xbail "no strace -V: $v"; + eval("v$1"); + }; + $ver ge v4.16 or skip "$cmd too old for syscall injection (". + sprintf('v%vd', $ver). ' < v4.16)', 1; + $cmd } -sub DESTROY { - my ($self) = @_; - return if $self->{owner} != $$; - if (my $tail_pid = delete $self->{tail_pid}) { - PublicInbox::TestCommon::wait_for_tail($tail_pid, -1); - CORE::kill('TERM', $tail_pid); - } - $self->join('TERM'); +sub oct_is ($$$) { + my ($got, $exp, $msg) = @_; + @_ = (sprintf('0%03o', $got), sprintf('0%03o', $exp), $msg); + goto &is; # tail recursion to get lineno from callers on failure } package PublicInbox::TestCommon::InboxWakeup; |