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 Socket qw(SOMAXCONN);
  10 use Time::HiRes qw(sleep time);
  11 use IO::Socket::INET;
  12 use IO::Socket::UNIX;
  13 use Carp qw(croak);
  14 use POSIX qw(dup2 _exit setpgid :signal_h SEEK_SET F_SETFD);
  15 use File::Temp 0.19 (); # 0.19 for ->newdir
  16 our ($tmpdir, $errfh, $err_log, $u_sock, $u_conf, $daemon_pid,
  17         $pid_file, $wtest_sock, $fifo);
  18 our @EXPORT = qw(unicorn slurp tcp_server tcp_start unicorn
  19         $tmpdir $errfh $err_log $u_sock $u_conf $daemon_pid $pid_file
  20         $wtest_sock $fifo
  21         SEEK_SET tcp_host_port which spawn check_stderr unix_start slurp_hdr
  22         do_req stop_daemon sleep time mkfifo_die kill_until_dead write_file);
  23
  24 my ($base) = ($0 =~ m!\b([^/]+)\.[^\.]+\z!);
  25 $tmpdir = File::Temp->newdir("unicorn-$base-XXXX", TMPDIR => 1);
  26
  27 $wtest_sock = "$tmpdir/wtest.sock";
  28 $err_log = "$tmpdir/err.log";
  29 $pid_file = "$tmpdir/pid";
  30 $fifo = "$tmpdir/fifo";
  31 $u_sock = "$tmpdir/u.sock";
  32 $u_conf = "$tmpdir/u.conf.rb";
  33 open($errfh, '>>', $err_log);
  34
  35 if (my $t = $ENV{TAIL}) {
  36         my @tail = $t =~ /tail/ ? split(/\s+/, $t) : (qw(tail -F));
  37         push @tail, $err_log;
  38         my $pid = fork;
  39         if ($pid == 0) {
  40                 open STDOUT, '>&', \*STDERR;
  41                 exec @tail;
  42                 die "exec(@tail): $!";
  43         }
  44         say "# @tail";
  45         sleep 0.2;
  46         UnicornTest::AutoReap->new($pid);
  47 }
  48
  49 sub kill_until_dead ($;%) {
  50         my ($pid, %opt) = @_;
  51         my $tries = $opt{tries} // 1000;
  52         my $sig = $opt{sig} // 0;
  53         while (CORE::kill($sig, $pid) && --$tries) { sleep(0.01) }
  54         $tries or croak "PID: $pid died after signal ($sig)";
  55 }
  56
  57 sub stop_daemon (;$) {
  58         my ($is_END) = @_;
  59         kill('TERM', $daemon_pid);
  60         kill_until_dead $daemon_pid;
  61         if ($is_END && CORE::kill(0, $daemon_pid)) { # after done_testing
  62                 CORE::kill('KILL', $daemon_pid);
  63                 die "daemon_pid=$daemon_pid did not die";
  64         } else {
  65                 ok(!CORE::kill(0, $daemon_pid), 'daemonized unicorn gone');
  66                 undef $daemon_pid;
  67         }
  68 };
  69
  70 END {
  71         diag slurp($err_log) if $tmpdir;
  72         stop_daemon(1) if defined $daemon_pid;
  73 };
  74
  75 sub check_stderr (@) {
  76         my @log = @_;
  77         slurp($err_log) if !@log;
  78         diag("@log") if $ENV{V};
  79         my @err = grep(!/NameError.*Unicorn::Waiter/, grep(/error/i, @log));
  80         @err = grep(!/failed to set accept_filter=/, @err);
  81         @err = grep(!/perhaps accf_.*? needs to be loaded/, @err);
  82         is_deeply(\@err, [], 'no unexpected errors in stderr');
  83         is_deeply([grep(/SIGKILL/, @log)], [], 'no SIGKILL in stderr');
  84 }
  85
  86 sub slurp_hdr {
  87         my ($c) = @_;
  88         local $/ = "\r\n\r\n"; # affects both readline+chomp
  89         chomp(my $hdr = readline($c));
  90         my ($status, @hdr) = split(/\r\n/, $hdr);
  91         diag explain([ $status, \@hdr ]) if $ENV{V};
  92         ($status, \@hdr);
  93 }
  94
  95 sub unix_server (;$@) {
  96         my $l = shift // $u_sock;
  97         IO::Socket::UNIX->new(Listen => SOMAXCONN, Local => $l, Blocking => 0,
  98                                 Type => SOCK_STREAM, @_);
  99 }
 100
 101 sub unix_connect ($) {
 102         IO::Socket::UNIX->new(Peer => $_[0], Type => SOCK_STREAM);
 103 }
 104
 105 sub tcp_server {
 106         my %opt = (
 107                 ReuseAddr => 1,
 108                 Proto => 'tcp',
 109                 Type => SOCK_STREAM,
 110                 Listen => SOMAXCONN,
 111                 Blocking => 0,
 112                 @_,
 113         );
 114         eval {
 115                 die 'IPv4-only' if $ENV{TEST_IPV4_ONLY};
 116                 require IO::Socket::INET6;
 117                 IO::Socket::INET6->new(%opt, LocalAddr => '[::1]')
 118         } || eval {
 119                 die 'IPv6-only' if $ENV{TEST_IPV6_ONLY};
 120                 IO::Socket::INET->new(%opt, LocalAddr => '127.0.0.1')
 121         } || BAIL_OUT "failed to create TCP server: $! ($@)";
 122 }
 123
 124 sub tcp_host_port {
 125         my ($s) = @_;
 126         my ($h, $p) = ($s->sockhost, $s->sockport);
 127         my $ipv4 = $s->sockdomain == AF_INET;
 128         if (wantarray) {
 129                 $ipv4 ? ($h, $p) : ("[$h]", $p);
 130         } else {
 131                 $ipv4 ? "$h:$p" : "[$h]:$p";
 132         }
 133 }
 134
 135 sub unix_start ($@) {
 136         my ($dst, @req) = @_;
 137         my $s = unix_connect($dst) or BAIL_OUT "unix connect $dst: $!";
 138         $s->autoflush(1);
 139         print $s @req, "\r\n\r\n" if @req;
 140         $s;
 141 }
 142
 143 sub tcp_start ($@) {
 144         my ($dst, @req) = @_;
 145         my $addr = tcp_host_port($dst);
 146         my $s = ref($dst)->new(
 147                 Proto => 'tcp',
 148                 Type => SOCK_STREAM,
 149                 PeerAddr => $addr,
 150         ) or BAIL_OUT "failed to connect to $addr: $!";
 151         $s->autoflush(1);
 152         print $s @req, "\r\n\r\n" if @req;
 153         $s;
 154 }
 155
 156 sub slurp {
 157         open my $fh, '<', $_[0];
 158         local $/ if !wantarray;
 159         readline($fh);
 160 }
 161
 162 sub spawn {
 163         my $env = ref($_[0]) eq 'HASH' ? shift : undef;
 164         my $opt = ref($_[-1]) eq 'HASH' ? pop : {};
 165         my @cmd = @_;
 166         my $old = POSIX::SigSet->new;
 167         my $set = POSIX::SigSet->new;
 168         $set->fillset or die "sigfillset: $!";
 169         sigprocmask(SIG_SETMASK, $set, $old) or die "SIG_SETMASK: $!";
 170         pipe(my $r, my $w);
 171         my $pid = fork;
 172         if ($pid == 0) {
 173                 close $r;
 174                 $SIG{__DIE__} = sub {
 175                         warn(@_);
 176                         syswrite($w, my $num = $! + 0);
 177                         _exit(1);
 178                 };
 179
 180                 # pretend to be systemd (cf. sd_listen_fds(3))
 181                 my $cfd;
 182                 for ($cfd = 0; ($cfd < 3) || defined($opt->{$cfd}); $cfd++) {
 183                         my $io = $opt->{$cfd} // next;
 184                         my $pfd = fileno($io);
 185                         if ($pfd == $cfd) {
 186                                 fcntl($io, F_SETFD, 0);
 187                         } else {
 188                                 dup2($pfd, $cfd) // die "dup2($pfd, $cfd): $!";
 189                         }
 190                 }
 191                 if (($cfd - 3) > 0) {
 192                         $env->{LISTEN_PID} = $$;
 193                         $env->{LISTEN_FDS} = $cfd - 3;
 194                 }
 195
 196                 if (defined(my $pgid = $opt->{pgid})) {
 197                         setpgid(0, $pgid) // die "setpgid(0, $pgid): $!";
 198                 }
 199                 $SIG{$_} = 'DEFAULT' for grep(!/^__/, keys %SIG);
 200                 if (defined(my $cd = $opt->{-C})) { chdir $cd }
 201                 $old->delset(POSIX::SIGCHLD) or die "sigdelset CHLD: $!";
 202                 sigprocmask(SIG_SETMASK, $old) or die "SIG_SETMASK: ~CHLD: $!";
 203                 @ENV{keys %$env} = values(%$env) if $env;
 204                 exec { $cmd[0] } @cmd;
 205                 die "exec @cmd: $!";
 206         }
 207         close $w;
 208         sigprocmask(SIG_SETMASK, $old) or die "SIG_SETMASK(old): $!";
 209         if (my $cerrnum = do { local $/, <$r> }) {
 210                 $! = $cerrnum;
 211                 die "@cmd PID=$pid died: $!";
 212         }
 213         $pid;
 214 }
 215
 216 sub which {
 217         my ($file) = @_;
 218         return $file if index($file, '/') >= 0;
 219         for my $p (split(/:/, $ENV{PATH})) {
 220                 $p .= "/$file";
 221                 return $p if -x $p;
 222         }
 223         undef;
 224 }
 225
 226 # returns an AutoReap object
 227 sub unicorn {
 228         my %env;
 229         if (ref($_[0]) eq 'HASH') {
 230                 my $e = shift;
 231                 %env = %$e;
 232         }
 233         my @args = @_;
 234         push(@args, {}) if ref($args[-1]) ne 'HASH';
 235         $args[-1]->{2} //= $errfh; # stderr default
 236
 237         state $ruby = which($ENV{RUBY} // 'ruby');
 238         state $lib = File::Spec->rel2abs('lib');
 239         state $ver = $ENV{TEST_RUBY_VERSION} // `$ruby -e 'print RUBY_VERSION'`;
 240         state $eng = $ENV{TEST_RUBY_ENGINE} // `$ruby -e 'print RUBY_ENGINE'`;
 241         state $ext = File::Spec->rel2abs("test/$eng-$ver/ext/unicorn_http");
 242         state $exe = File::Spec->rel2abs("test/$eng-$ver/bin/unicorn");
 243         state $rl = $ENV{RUBYLIB} ? "$lib:$ext:$ENV{RUBYLIB}" : "$lib:$ext";
 244         $env{RUBYLIB} = $rl;
 245         my $pid = spawn(\%env, $ruby, $exe, @args);
 246         UnicornTest::AutoReap->new($pid);
 247 }
 248
 249 sub do_req ($@) {
 250         my ($dst, @req) = @_;
 251         my $c = ref($dst) ? tcp_start($dst, @req) : unix_start($dst, @req);
 252         return $c if !wantarray;
 253         my ($status, $hdr);
 254         # read headers iff HTTP/1.x request, HTTP/0.9 remains supported
 255         my ($first) = (join('', @req) =~ m!\A([^\r\n]+)!);
 256         ($status, $hdr) = slurp_hdr($c) if $first =~ m{\s*HTTP/\S+$};
 257         my $bdy = do { local $/; <$c> };
 258         close $c;
 259         ($status, $hdr, $bdy);
 260 }
 261
 262 sub mkfifo_die ($;$) {
 263         POSIX::mkfifo($_[0], $_[1] // 0600) or croak "mkfifo: $!";
 264 }
 265
 266 sub write_file ($$@) { # mode, filename, LIST (for print)
 267         open(my $fh, shift, shift);
 268         print $fh @_;
 269         # return $fh for futher writes if user wants it:
 270         defined(wantarray) && !wantarray ? $fh : close $fh;
 271 }
 272
 273 # automatically kill + reap children when this goes out-of-scope
 274 package UnicornTest::AutoReap;
 275 use v5.14;
 276 use autodie;
 277
 278 sub new {
 279         my (undef, $pid) = @_;
 280         bless { pid => $pid, owner => $$ }, __PACKAGE__
 281 }
 282
 283 sub do_kill {
 284         my ($self, $sig) = @_;
 285         kill($sig // 'TERM', $self->{pid});
 286 }
 287
 288 sub join {
 289         my ($self, $sig) = @_;
 290         my $pid = delete $self->{pid} or return;
 291         kill($sig, $pid) if defined $sig;
 292         my $ret = waitpid($pid, 0);
 293         $ret == $pid or die "BUG: waitpid($pid) != $ret";
 294 }
 295
 296 sub DESTROY {
 297         my ($self) = @_;
 298         return if $self->{owner} != $$;
 299         $self->join('TERM');
 300 }
 301
 302 package main; # inject ourselves into the t/*.t script
 303 UnicornTest->import;
 304 Test::More->import;
 305 # try to ensure ->DESTROY fires:
 306 $SIG{TERM} = sub { exit(15 + 128) };
 307 $SIG{INT} = sub { exit(2 + 128) };
 308 $SIG{PIPE} = sub { exit(13 + 128) };
 309 1;