t/lib.perl

   1 #!perl -w
   2 # Copyright (C) unicorn hackers <unicorn-public@80x24.org>
   3 # License: GPL-3.0+ <https://www.gnu.org/licenses/gpl-3.0.txt>
   4 package UnicornTest;
   5 use v5.14;
   6 use parent qw(Exporter);
   7 use autodie;
   8 use Test::More;
   9 use IO::Socket::INET;
  10 use POSIX qw(dup2 _exit setpgid :signal_h SEEK_SET F_SETFD);
  11 use File::Temp 0.19 (); # 0.19 for ->newdir
  12 our ($tmpdir, $errfh);
  13 our @EXPORT = qw(unicorn slurp tcp_server tcp_connect unicorn $tmpdir $errfh
  14         SEEK_SET tcp_host_port start_req which spawn);
  15
  16 my ($base) = ($0 =~ m!\b([^/]+)\.[^\.]+\z!);
  17 $tmpdir = File::Temp->newdir("unicorn-$base-XXXX", TMPDIR => 1);
  18 open($errfh, '>>', "$tmpdir/err.log");
  19
  20 sub tcp_server {
  21         my %opt = (
  22                 ReuseAddr => 1,
  23                 Proto => 'tcp',
  24                 Type => SOCK_STREAM,
  25                 Listen => SOMAXCONN,
  26                 Blocking => 0,
  27                 @_,
  28         );
  29         eval {
  30                 die 'IPv4-only' if $ENV{TEST_IPV4_ONLY};
  31                 require IO::Socket::INET6;
  32                 IO::Socket::INET6->new(%opt, LocalAddr => '[::1]')
  33         } || eval {
  34                 die 'IPv6-only' if $ENV{TEST_IPV6_ONLY};
  35                 IO::Socket::INET->new(%opt, LocalAddr => '127.0.0.1')
  36         } || BAIL_OUT "failed to create TCP server: $! ($@)";
  37 }
  38
  39 sub tcp_host_port {
  40         my ($s) = @_;
  41         my ($h, $p) = ($s->sockhost, $s->sockport);
  42         my $ipv4 = $s->sockdomain == AF_INET;
  43         if (wantarray) {
  44                 $ipv4 ? ($h, $p) : ("[$h]", $p);
  45         } else {
  46                 $ipv4 ? "$h:$p" : "[$h]:$p";
  47         }
  48 }
  49
  50 sub tcp_connect {
  51         my ($dest, %opt) = @_;
  52         my $addr = tcp_host_port($dest);
  53         my $s = ref($dest)->new(
  54                 Proto => 'tcp',
  55                 Type => SOCK_STREAM,
  56                 PeerAddr => $addr,
  57                 %opt,
  58         ) or BAIL_OUT "failed to connect to $addr: $!";
  59         $s->autoflush(1);
  60         $s;
  61 }
  62
  63 sub start_req {
  64         my ($srv, @req) = @_;
  65         my $c = tcp_connect($srv);
  66         print $c @req, "\r\n\r\n";
  67         $c;
  68 }
  69
  70 sub slurp {
  71         open my $fh, '<', $_[0];
  72         local $/;
  73         readline($fh);
  74 }
  75
  76 sub spawn {
  77         my $env = ref($_[0]) eq 'HASH' ? shift : undef;
  78         my $opt = ref($_[-1]) eq 'HASH' ? pop : {};
  79         my @cmd = @_;
  80         my $old = POSIX::SigSet->new;
  81         my $set = POSIX::SigSet->new;
  82         $set->fillset or die "sigfillset: $!";
  83         sigprocmask(SIG_SETMASK, $set, $old) or die "SIG_SETMASK: $!";
  84         pipe(my $r, my $w);
  85         my $pid = fork;
  86         if ($pid == 0) {
  87                 close $r;
  88                 $SIG{__DIE__} = sub {
  89                         warn(@_);
  90                         syswrite($w, my $num = $! + 0);
  91                         _exit(1);
  92                 };
  93
  94                 # pretend to be systemd (cf. sd_listen_fds(3))
  95                 my $cfd;
  96                 for ($cfd = 0; ($cfd < 3) || defined($opt->{$cfd}); $cfd++) {
  97                         my $io = $opt->{$cfd} // next;
  98                         my $pfd = fileno($io);
  99                         if ($pfd == $cfd) {
 100                                 fcntl($io, F_SETFD, 0);
 101                         } else {
 102                                 dup2($pfd, $cfd) // die "dup2($pfd, $cfd): $!";
 103                         }
 104                 }
 105                 if (($cfd - 3) > 0) {
 106                         $env->{LISTEN_PID} = $$;
 107                         $env->{LISTEN_FDS} = $cfd - 3;
 108                 }
 109
 110                 if (defined(my $pgid = $opt->{pgid})) {
 111                         setpgid(0, $pgid) // die "setpgid(0, $pgid): $!";
 112                 }
 113                 $SIG{$_} = 'DEFAULT' for grep(!/^__/, keys %SIG);
 114                 if (defined(my $cd = $opt->{-C})) { chdir $cd }
 115                 $old->delset(POSIX::SIGCHLD) or die "sigdelset CHLD: $!";
 116                 sigprocmask(SIG_SETMASK, $old) or die "SIG_SETMASK: ~CHLD: $!";
 117                 @ENV{keys %$env} = values(%$env) if $env;
 118                 exec { $cmd[0] } @cmd;
 119                 die "exec @cmd: $!";
 120         }
 121         close $w;
 122         sigprocmask(SIG_SETMASK, $old) or die "SIG_SETMASK(old): $!";
 123         if (my $cerrnum = do { local $/, <$r> }) {
 124                 $! = $cerrnum;
 125                 die "@cmd PID=$pid died: $!";
 126         }
 127         $pid;
 128 }
 129
 130 sub which {
 131         my ($file) = @_;
 132         return $file if index($file, '/') >= 0;
 133         for my $p (split(/:/, $ENV{PATH})) {
 134                 $p .= "/$file";
 135                 return $p if -x $p;
 136         }
 137         undef;
 138 }
 139
 140 # returns an AutoReap object
 141 sub unicorn {
 142         my %env;
 143         if (ref($_[0]) eq 'HASH') {
 144                 my $e = shift;
 145                 %env = %$e;
 146         }
 147         my @args = @_;
 148         push(@args, {}) if ref($args[-1]) ne 'HASH';
 149         $args[-1]->{2} //= $errfh; # stderr default
 150
 151         state $ruby = which($ENV{RUBY} // 'ruby');
 152         state $lib = File::Spec->rel2abs('lib');
 153         state $ver = $ENV{TEST_RUBY_VERSION} // `$ruby -e 'print RUBY_VERSION'`;
 154         state $eng = $ENV{TEST_RUBY_ENGINE} // `$ruby -e 'print RUBY_ENGINE'`;
 155         state $ext = File::Spec->rel2abs("test/$eng-$ver/ext/unicorn_http");
 156         state $exe = File::Spec->rel2abs('bin/unicorn');
 157         my $pid = spawn(\%env, $ruby, '-I', $lib, '-I', $ext, $exe, @args);
 158         UnicornTest::AutoReap->new($pid);
 159 }
 160
 161 # automatically kill + reap children when this goes out-of-scope
 162 package UnicornTest::AutoReap;
 163 use v5.14;
 164 use autodie;
 165
 166 sub new {
 167         my (undef, $pid) = @_;
 168         bless { pid => $pid, owner => $$ }, __PACKAGE__
 169 }
 170
 171 sub do_kill {
 172         my ($self, $sig) = @_;
 173         kill($sig // 'TERM', $self->{pid});
 174 }
 175
 176 sub join {
 177         my ($self, $sig) = @_;
 178         my $pid = delete $self->{pid} or return;
 179         kill($sig, $pid) if defined $sig;
 180         my $ret = waitpid($pid, 0);
 181         $ret == $pid or die "BUG: waitpid($pid) != $ret";
 182 }
 183
 184 sub DESTROY {
 185         my ($self) = @_;
 186         return if $self->{owner} != $$;
 187         $self->join('TERM');
 188 }
 189
 190 package main; # inject ourselves into the t/*.t script
 191 UnicornTest->import;
 192 Test::More->import;
 193 # try to ensure ->DESTROY fires:
 194 $SIG{TERM} = sub { exit(15 + 128) };
 195 $SIG{INT} = sub { exit(2 + 128) };
 196 $SIG{PIPE} = sub { exit(13 + 128) };
 197 1;