83 lines
2.3 KiB
Perl
83 lines
2.3 KiB
Perl
package StartXDummy;
|
||
# vim:ts=4:sw=4:expandtab
|
||
|
||
use strict;
|
||
use warnings;
|
||
use Exporter 'import';
|
||
use Time::HiRes qw(sleep);
|
||
use v5.10;
|
||
|
||
our @EXPORT = qw(start_xdummy);
|
||
|
||
# reads in a whole file
|
||
sub slurp {
|
||
open(my $fh, '<', shift) or return '';
|
||
local $/;
|
||
<$fh>;
|
||
}
|
||
|
||
=head2 start_xdummy($parallel)
|
||
|
||
Starts C<$parallel> (or number of cores * 2 if undef) Xdummy processes (see
|
||
the file ./Xdummy) and returns two arrayrefs: a list of X11 display numbers to
|
||
the Xdummy processes and a list of PIDs of the processes.
|
||
|
||
=cut
|
||
sub start_xdummy {
|
||
my ($parallel) = @_;
|
||
|
||
my @displays = ();
|
||
my @childpids = ();
|
||
|
||
# Yeah, I know it’s non-standard, but Perl’s POSIX module doesn’t have
|
||
# _SC_NPROCESSORS_CONF.
|
||
my $cpuinfo = slurp('/proc/cpuinfo');
|
||
my $num_cores = scalar grep { /model name/ } split("\n", $cpuinfo);
|
||
# If /proc/cpuinfo does not exist, we fall back to 2 cores.
|
||
$num_cores ||= 2;
|
||
|
||
$parallel ||= $num_cores * 2;
|
||
|
||
# First get the last used display number, then increment it by one.
|
||
# Effectively falls back to 1 if no X server is running.
|
||
my ($displaynum) = reverse ('0', sort </tmp/.X11-unix/X*>);
|
||
$displaynum =~ s/.*(\d)$/$1/;
|
||
$displaynum++;
|
||
|
||
say "Starting $parallel Xdummy instances, starting at :$displaynum...";
|
||
|
||
for my $idx (0 .. ($parallel-1)) {
|
||
my $pid = fork();
|
||
die "Could not fork: $!" unless defined($pid);
|
||
if ($pid == 0) {
|
||
# Child, close stdout/stderr, then start Xdummy.
|
||
close STDOUT;
|
||
close STDERR;
|
||
# We use -config /dev/null to prevent Xdummy from using the system
|
||
# Xorg configuration. The tests should be independant from the
|
||
# actual system X configuration.
|
||
exec './Xdummy', ":$displaynum", '-config', '/dev/null';
|
||
exit 1;
|
||
}
|
||
push(@childpids, $pid);
|
||
push(@displays, ":$displaynum");
|
||
$displaynum++;
|
||
}
|
||
|
||
# Wait until the X11 sockets actually appear. Pretty ugly solution, but as
|
||
# long as we can’t socket-activate X11…
|
||
my $sockets_ready;
|
||
do {
|
||
$sockets_ready = 1;
|
||
for (@displays) {
|
||
my $path = "/tmp/.X11-unix/X" . substr($_, 1);
|
||
$sockets_ready = 0 unless -S $path;
|
||
}
|
||
sleep 0.1;
|
||
} until $sockets_ready;
|
||
|
||
return \@displays, \@childpids;
|
||
}
|
||
|
||
1
|