git.sur5r.net Git - i3/i3/blob - testcases/lib/TestWorker.pm

   1 # vim:ts=4:sw=4:sts=4:expandtab
   2 package TestWorker;
   3 use strict; use warnings;
   4 use v5.10;
   5
   6 use Socket qw(AF_UNIX SOCK_DGRAM PF_UNSPEC);
   7 use IO::Handle; # for ->autoflush
   8
   9 use POSIX ();
  10
  11 use Exporter 'import';
  12 our @EXPORT = qw(worker worker_next);
  13
  14 use File::Basename qw(basename);
  15 my @x;
  16
  17 sub worker {
  18     my ($display, $x, $outdir) = @_;
  19
  20     # make sure $x hangs around
  21     push @x, $x;
  22
  23     socketpair(my $ipc_child, my $ipc, AF_UNIX, SOCK_DGRAM, PF_UNSPEC)
  24         or die "socketpair: $!";
  25
  26     $ipc->autoflush(1);
  27     $ipc_child->autoflush(1);
  28
  29     my $worker = {
  30         display => $display,
  31         ipc => $ipc,
  32     };
  33
  34     my $pid = fork // die "could not fork: $!";
  35
  36     if ($pid == 0) {
  37         close $ipc;
  38         undef @complete_run::CLEANUP;
  39         # reap dead test children
  40         $SIG{CHLD} = sub { waitpid -1, POSIX::WNOHANG };
  41
  42         $worker->{ipc} = $ipc_child;
  43
  44         require i3test;
  45         # TODO: recycle $x
  46         # unfortunately this fails currently with:
  47         # Could not get reply for: xcb_intern_atom_reply at X11/XCB/Atom.pm line 22.
  48
  49         # $i3test::x = bless $x, 'i3test::X11';
  50         worker_wait($worker, $outdir);
  51         exit 23;
  52
  53     }
  54
  55     close $ipc_child;
  56     push @complete_run::CLEANUP, sub {
  57         # signal via empty line to exit itself
  58         syswrite($ipc, "\n") or kill('TERM', $pid);
  59         waitpid $pid, 0;
  60     };
  61
  62     return $worker;
  63
  64 }
  65
  66 our $EOF = "# end of file\n";
  67 sub worker_wait {
  68     my ($self, $outdir) = @_;
  69
  70     my $ipc = $self->{ipc};
  71     my $ipc_fd = fileno($ipc);
  72
  73     while (defined(my $file = $ipc->getline)) {
  74         chomp $file;
  75
  76         exit unless $file;
  77
  78         die "tried to launch nonexistend testfile $file: $!\n"
  79             unless -e $file;
  80
  81         # start a new and self contained process:
  82         # whatever happens in the testfile should *NOT* effect us.
  83
  84         my $pid = fork // die "could not fork: $!";
  85         if ($pid == 0) {
  86             undef @complete_run::CLEANUP;
  87             local $SIG{CHLD};
  88
  89             $0 = $file;
  90
  91             POSIX::dup2($ipc_fd, 0);
  92             POSIX::dup2($ipc_fd, 1);
  93             POSIX::dup2(1, 2);
  94
  95             # get Test::Builder singleton
  96             my $test = Test::Builder->new;
  97
  98             # Test::Builder dups stdout/stderr while loading.
  99             # we need to reset them here to point to $ipc
 100             $test->output(\*STDOUT);
 101             $test->failure_output(\*STDERR);
 102             $test->todo_output(\*STDOUT);
 103
 104             @ENV{qw(DISPLAY TESTNAME OUTDIR VALGRIND STRACE COVERAGE RESTART)}
 105                 = ($self->{display}, basename($file), $outdir, 0, 0, 0, 0);
 106
 107             package main;
 108             local $@;
 109             do "./$file";
 110             $test->ok(undef, "$@") if $@;
 111
 112             # XXX hack, we need to trigger the read watcher once more
 113             # to signal eof to TAP::Parser
 114             print $EOF;
 115
 116             exit 0;
 117         }
 118     }
 119 }
 120
 121 sub worker_next {
 122     my ($self, $file) = @_;
 123
 124     my $ipc = $self->{ipc};
 125     syswrite $ipc, "$file\n" or die "syswrite: $!";
 126 }
 127
 128 __PACKAGE__ __END__