From 9a7d7919a641edba90f9e7a0d36fa6519857f832 Mon Sep 17 00:00:00 2001 From: Maik Fischer Date: Tue, 29 Nov 2011 13:48:04 +0100 Subject: [PATCH] testcases: introduce TestWorker.pm instead of executing a new perl interpreter (via TAP::Parser) each time we start a testfile, fork a TestWorker for each display. Each worker preloads i3test via 'require', blocking waits on its ipc to get a new filename, forks itself upon arrival and 'do'es this testscript. --- testcases/complete-run.pl | 154 +++++++++++++++++++---------------- testcases/lib/StartXDummy.pm | 2 +- testcases/lib/TestWorker.pm | 128 +++++++++++++++++++++++++++++ testcases/lib/i3test.pm | 8 +- 4 files changed, 216 insertions(+), 76 deletions(-) create mode 100644 testcases/lib/TestWorker.pm diff --git a/testcases/complete-run.pl b/testcases/complete-run.pl index d74da831..a028674b 100755 --- a/testcases/complete-run.pl +++ b/testcases/complete-run.pl @@ -1,19 +1,16 @@ #!/usr/bin/env perl # vim:ts=4:sw=4:expandtab # © 2010-2011 Michael Stapelberg and contributors - +package complete_run; use strict; use warnings; use v5.10; # the following are modules which ship with Perl (>= 5.10): use Pod::Usage; use Cwd qw(abs_path); -use File::Basename qw(basename); use File::Temp qw(tempfile tempdir); use Getopt::Long; -use IO::Socket::UNIX; use POSIX (); -use Time::HiRes qw(sleep gettimeofday tv_interval); use TAP::Harness; use TAP::Parser; use TAP::Parser::Aggregator; @@ -21,27 +18,18 @@ use TAP::Parser::Aggregator; use lib qw(lib); use StartXDummy; use StatusLine; +use TestWorker; # the following modules are not shipped with Perl use AnyEvent; use AnyEvent::Util; use AnyEvent::Handle; use AnyEvent::I3 qw(:all); -use X11::XCB; +use X11::XCB::Connection; # Close superfluous file descriptors which were passed by running in a VIM # subshell or situations like that. AnyEvent::Util::close_all_fds_except(0, 1, 2); -# We actually use AnyEvent to make sure it loads an event loop implementation. -# Afterwards, we overwrite SIGCHLD: -my $cv = AnyEvent->condvar; - -# Install a dummy CHLD handler to overwrite the CHLD handler of AnyEvent. -# AnyEvent’s handler wait()s for every child which conflicts with TAP (TAP -# needs to get the exit status to determine if a test is successful). -$SIG{CHLD} = sub { -}; - # convinience wrapper to write to the log file my $log; sub Log { say $log "@_" } @@ -73,38 +61,39 @@ pod2usage(-verbose => 2, -exitcode => 0) if $help; # No displays specified, let’s start some Xdummy instances. @displays = start_xdummy($parallel) if @displays == 0; +# 1: create an output directory for this test-run +my $outdir = "testsuite-"; +$outdir .= POSIX::strftime("%Y-%m-%d-%H-%M-%S-", localtime()); +$outdir .= `git describe --tags`; +chomp($outdir); +mkdir($outdir) or die "Could not create $outdir"; +unlink("latest") if -e "latest"; +symlink("$outdir", "latest") or die "Could not symlink latest to $outdir"; + # connect to all displays for two reasons: # 1: check if the display actually works # 2: keep the connection open so that i3 is not the only client. this prevents # the X server from exiting (Xdummy will restart it, but not quick enough # sometimes) -my @conns; +my @worker; for my $display (@displays) { my $screen; - my $x = X11::XCB->new($display, $screen); + my $x = X11::XCB::Connection->new(display => $display); if ($x->has_error) { die "Could not connect to display $display\n"; } else { - push @conns, $x; + # start a TestWorker for each display + push @worker, worker($display, $x, $outdir); } } -# 1: get a list of all testcases +# 2: get a list of all testcases my @testfiles = @ARGV; # if no files were passed on command line, run all tests from t/ @testfiles = if @testfiles == 0; -# 2: create an output directory for this test-run -my $outdir = "testsuite-"; -$outdir .= POSIX::strftime("%Y-%m-%d-%H-%M-%S-", localtime()); -$outdir .= `git describe --tags`; -chomp($outdir); -mkdir($outdir) or die "Could not create $outdir"; -unlink("latest") if -e "latest"; -symlink("$outdir", "latest") or die "Could not symlink latest to $outdir"; - my $logfile = "$outdir/complete-run.log"; open $log, '>', $logfile or die "Could not create '$logfile': $!"; say "Writing logfile to '$logfile'..."; @@ -119,9 +108,11 @@ $aggregator->start(); status_init(displays => \@displays, tests => $num); +my $cv = AE::cv; + # We start tests concurrently: For each display, one test gets started. Every # test starts another test after completing. -for (@displays) { $cv->begin; take_job($_) } +for (@worker) { $cv->begin; take_job($_) } $cv->recv; @@ -132,6 +123,7 @@ print "\n\n"; for (@done) { my ($test, $output) = @$_; + say "no output for $test" unless $output; Log "output for $test:"; Log $output; # print error messages of failed tests @@ -143,7 +135,7 @@ $harness->summary($aggregator); close $log; -cleanup(); +END { cleanup() } exit 0; @@ -158,72 +150,92 @@ exit 0; # triggered to finish testing. # sub take_job { - my ($display) = @_; + my ($worker) = @_; my $test = shift @testfiles or return $cv->end; - my $basename = basename($test); + my $display = $worker->{display}; - Log status($display, "Starting $test"); + Log status($display, "$test: starting"); + worker_next($worker, $test); + # create a TAP::Parser with an in-memory fh my $output; - open(my $spool, '>', \$output); my $parser = TAP::Parser->new({ - exec => [ 'sh', '-c', qq|DISPLAY=$display TESTNAME="$basename" OUTDIR="$outdir" VALGRIND=$valgrind STRACE=$strace COVERAGE=$coverage_testing /usr/bin/perl -Ilib $test| ], - spool => $spool, - merge => 1, + source => do { open(my $fh, '<', \$output); $fh }, }); - my $tests_completed; - - my @watchers; - my ($stdout, $stderr) = $parser->get_select_handles; - for my $handle ($parser->get_select_handles) { - my $w; - $w = AnyEvent->io( - fh => $handle, - poll => 'r', - cb => sub { - # Ignore activity on stderr (unnecessary with merge => 1, - # but let’s keep it in here if we want to use merge => 0 - # for some reason in the future). - return if defined($stderr) and $handle == $stderr; + my $ipc = $worker->{ipc}; - my $result = $parser->next; - if (defined($result)) { - $tests_completed++; - status($display, "Running $test: [$tests_completed/??]"); - # TODO: check if we should bail out + my $w; + $w = AnyEvent->io( + fh => $ipc, + poll => 'r', + cb => sub { + state $tests_completed = 0; + state $partial = ''; + + sysread($ipc, my $buf, 4096) or die "sysread: $!"; + + if ($partial) { + $buf = $partial . $buf; + $partial = ''; + } + + # make sure we feed TAP::Parser complete lines so it doesn't blow up + if (substr($buf, -1, 1) ne "\n") { + my $nl = rindex($buf, "\n"); + if ($nl == -1) { + $partial = $buf; return; } - # $result is not defined, we are done parsing - Log status($display, "$test finished"); - close($parser->delete_spool); - $aggregator->add($test, $parser); - push @done, [ $test, $output ]; + # strip partial from buffer + $partial = substr($buf, $nl + 1, ''); + } + + # count lines before stripping eof-marker otherwise we might + # end up with for (1 .. 0) { } which would effectivly skip the loop + my $lines = $buf =~ tr/\n//; + my $t_eof = $buf =~ s/^$TestWorker::EOF$//m; - status_completed(scalar @done); + $output .= $buf; - undef $_ for @watchers; - if (@done == $num) { - $cv->end; - } else { - take_job($display); + for (1 .. $lines) { + my $result = $parser->next; + if (defined($result) and $result->is_test) { + $tests_completed++; + status($display, "$test: [$tests_completed/??] "); } } - ); - push @watchers, $w; - } + + return unless $t_eof; + + Log status($display, "$test: finished"); + status_completed(scalar @done); + + $aggregator->add($test, $parser); + push @done, [ $test, $output ]; + + undef $w; + take_job($worker); + } + ); } sub cleanup { $_->() for our @CLEANUP; + exit; } # must be in a begin block because we C above -BEGIN { $SIG{$_} = \&cleanup for qw(INT TERM QUIT KILL) } +BEGIN { + $SIG{$_} = sub { + require Carp; Carp::cluck("Caught SIG$_[0]\n"); + cleanup(); + } for qw(INT TERM QUIT KILL PIPE) +} __END__ diff --git a/testcases/lib/StartXDummy.pm b/testcases/lib/StartXDummy.pm index 2f3cfeb6..0764c4ec 100644 --- a/testcases/lib/StartXDummy.pm +++ b/testcases/lib/StartXDummy.pm @@ -65,7 +65,7 @@ sub start_xdummy { exec './Xdummy', ":$displaynum", '-config', '/dev/null'; exit 1; } - push(@main::CLEANUP, sub { kill(15, $pid) }); + push(@complete_run::CLEANUP, sub { kill(15, $pid) }); push(@displays, ":$displaynum"); push(@sockets_waiting, $x_socketpath . $displaynum); $displaynum++; diff --git a/testcases/lib/TestWorker.pm b/testcases/lib/TestWorker.pm new file mode 100644 index 00000000..85539626 --- /dev/null +++ b/testcases/lib/TestWorker.pm @@ -0,0 +1,128 @@ +# vim:ts=4:sw=4:sts=4:expandtab +package TestWorker; +use strict; use warnings; +use v5.10; + +use Socket qw(AF_UNIX SOCK_DGRAM PF_UNSPEC); +use IO::Handle; # for ->autoflush + +use POSIX (); + +use Exporter 'import'; +our @EXPORT = qw(worker worker_next); + +use File::Basename qw(basename); +my @x; + +sub worker { + my ($display, $x, $outdir) = @_; + + # make sure $x hangs around + push @x, $x; + + socketpair(my $ipc_child, my $ipc, AF_UNIX, SOCK_DGRAM, PF_UNSPEC) + or die "socketpair: $!"; + + $ipc->autoflush(1); + $ipc_child->autoflush(1); + + my $worker = { + display => $display, + ipc => $ipc, + }; + + my $pid = fork // die "could not fork: $!"; + + if ($pid == 0) { + close $ipc; + undef @complete_run::CLEANUP; + # reap dead test children + $SIG{CHLD} = sub { waitpid -1, POSIX::WNOHANG }; + + $worker->{ipc} = $ipc_child; + + require i3test; + # TODO: recycle $x + # unfortunately this fails currently with: + # Could not get reply for: xcb_intern_atom_reply at X11/XCB/Atom.pm line 22. + + # $i3test::x = bless $x, 'i3test::X11'; + worker_wait($worker, $outdir); + exit 23; + + } + + close $ipc_child; + push @complete_run::CLEANUP, sub { + # signal via empty line to exit itself + syswrite($ipc, "\n") or kill('TERM', $pid); + waitpid $pid, 0; + }; + + return $worker; + +} + +our $EOF = "# end of file\n"; +sub worker_wait { + my ($self, $outdir) = @_; + + my $ipc = $self->{ipc}; + my $ipc_fd = fileno($ipc); + + while (defined(my $file = $ipc->getline)) { + chomp $file; + + exit unless $file; + + die "tried to launch nonexistend testfile $file: $!\n" + unless -e $file; + + # start a new and self contained process: + # whatever happens in the testfile should *NOT* effect us. + + my $pid = fork // die "could not fork: $!"; + if ($pid == 0) { + undef @complete_run::CLEANUP; + local $SIG{CHLD}; + + $0 = $file; + + POSIX::dup2($ipc_fd, 0); + POSIX::dup2($ipc_fd, 1); + POSIX::dup2(1, 2); + + # get Test::Builder singleton + my $test = Test::Builder->new; + + # Test::Builder dups stdout/stderr while loading. + # we need to reset them here to point to $ipc + $test->output(\*STDOUT); + $test->failure_output(\*STDERR); + $test->todo_output(\*STDOUT); + + @ENV{qw(DISPLAY TESTNAME OUTDIR VALGRIND STRACE COVERAGE)} + = ($self->{display}, basename($file), $outdir, 0, 0, 0); + + package main; + local $@; + do "./$file"; + $test->ok(undef, "$@") if $@; + + # XXX hack, we need to trigger the read watcher once more + # to signal eof to TAP::Parser + print $EOF; + + exit 0; + } + } +} + +sub worker_next { + my ($self, $file) = @_; + + my $ipc = $self->{ipc}; + syswrite $ipc, "$file\n" or die "syswrite: $!"; +} + +__PACKAGE__ __END__ diff --git a/testcases/lib/i3test.pm b/testcases/lib/i3test.pm index 824db236..aecec534 100644 --- a/testcases/lib/i3test.pm +++ b/testcases/lib/i3test.pm @@ -16,6 +16,10 @@ use SocketActivation; use v5.10; +# preload +use Test::More (); +use Data::Dumper (); + use Exporter (); our @EXPORT = qw( get_workspace_names @@ -471,10 +475,6 @@ sub get_socket_path { # # launches a new i3 process with the given string as configuration file. # useful for tests which test specific config file directives. -# -# be sure to use !NO_I3_INSTANCE! somewhere in the file to signal -# complete-run.pl that it should not create an instance of i3 -# sub launch_with_config { my ($config, %args) = @_; -- 2.39.5