X-Git-Url: http://www.git.stargrave.org/?a=blobdiff_plain;f=lib%2FPublicInbox%2FTestCommon.pm;h=8a34e45a24a48d2d6682e0298380bdbe222c2b54;hb=ee8746e6db4dbe5a6cdb0d6080f467bc27693b3a;hp=ecf7a261b6f485447dce78ca6f10fd74660f4201;hpb=d323a16ced5e3a77136a1ebca4a2f7d5678121c4;p=public-inbox.git diff --git a/lib/PublicInbox/TestCommon.pm b/lib/PublicInbox/TestCommon.pm index ecf7a261..8a34e45a 100644 --- a/lib/PublicInbox/TestCommon.pm +++ b/lib/PublicInbox/TestCommon.pm @@ -6,7 +6,7 @@ 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 :seek); use POSIX qw(dup2); use IO::Socket::INET; use File::Spec; @@ -14,6 +14,9 @@ our @EXPORT; my $lei_loud = $ENV{TEST_LEI_ERR_LOUD}; my $tail_cmd = $ENV{TAIL}; our ($lei_opt, $lei_out, $lei_err, $lei_cwdfh); + +$_ = 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 @@ -90,33 +93,43 @@ 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, skipping $nr tests") } -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, $nr) = @_; + state ($cur_int, $cur_ver); + $cur_int //= do { + chomp($cur_ver = xqx([qw(git --version)])); + my @v = ($cur_ver =~ /version (\d+)\.(\d+)(?:\.(\d+))?/); + ($v[0] << 24) | ($v[1] << 16) | ($v[2] // 0); + }; + my ($req_maj, $req_min, $req_sub) = split(/\./, $req); 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"; - } - 1; + + return 1 if $cur_int >= $req_int; + return plan skip_all => "git $req+ required, have $cur_ver" if !$nr; + defined(wantarray) ? undef : + skip("git $req+ required (have $cur_ver), skipping $nr tests") } +my %IPv6_VERSION = ( + 'Net::NNTP' => 3.00, + 'Mail::IMAPClient' => 3.40, + 'HTTP::Tiny' => 0.042, +); + sub require_mods { my @mods = @_; my $maybe = pop @mods if $mods[-1] =~ /\A[0-9]+\z/; @@ -136,7 +149,7 @@ sub require_mods { push @mods, qw(Parse::RecDescent DBD::SQLite Email::Address::XS||Mail::Address); next; - } elsif ($mod eq '-nntpd') { + } elsif ($mod eq '-nntpd' || $mod eq 'v2') { push @mods, qw(DBD::SQLite); next; } @@ -167,6 +180,9 @@ 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"; @@ -279,6 +295,7 @@ sub run_script ($;$$) { my ($cmd, $env, $opt) = @_; my ($key, @argv) = @$cmd; my $run_mode = $ENV{TEST_RUN_MODE} // $opt->{run_mode} // 1; + $run_mode = 0 if $key eq '-clone'; # relies on SIGCHLD + waitpid(-1) my $sub = $run_mode == 0 ? undef : key2sub($key); my $fhref = []; my $spawn_opt = {}; @@ -463,19 +480,20 @@ sub start_script { my $pid = fork // die "fork: $!\n"; if ($pid == 0) { eval { PublicInbox::DS->Reset }; + for (@{delete($opt->{-CLOFORK}) // []}) { + close($_) or die "close $!"; + } # 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) // die "F_SETFD: $!"; + } 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; @@ -559,7 +577,7 @@ SKIP: { 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); @@ -734,20 +752,28 @@ 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> };