mirror of
https://github.com/solemnwarning/ipxwrapper
synced 2024-12-30 16:45:37 +01:00
155 lines
3.4 KiB
Perl
155 lines
3.4 KiB
Perl
# IPXWrapper test suite
|
|
# Copyright (C) 2023 Daniel Collins <solemnwarning@solemnwarning.net>
|
|
#
|
|
# This program is free software; you can redistribute it and/or modify it
|
|
# under the terms of the GNU General Public License version 2 as published by
|
|
# the Free Software Foundation.
|
|
#
|
|
# This program is distributed in the hope that it will be useful, but WITHOUT
|
|
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
|
# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
|
|
# more details.
|
|
#
|
|
# You should have received a copy of the GNU General Public License along with
|
|
# this program; if not, write to the Free Software Foundation, Inc., 51
|
|
# Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
package IPXWrapper::DOSBoxServer;
|
|
|
|
use File::Temp;
|
|
use IPC::Open3;
|
|
use POSIX qw(:signal_h);
|
|
use Proc::ProcessTable;
|
|
use Test::Spec;
|
|
|
|
sub new
|
|
{
|
|
my ($class, $port) = @_;
|
|
|
|
my $self = bless({
|
|
xvfb_run_pid => undef,
|
|
dosbox_pid => undef,
|
|
}, $class);
|
|
|
|
# For some reason DOSBox sometimes fails to start under Xvfb... so
|
|
# retry a few times if that happens.
|
|
|
|
for(my $i = 0; $i < 5; ++$i)
|
|
{
|
|
eval {
|
|
$self->_start($port);
|
|
};
|
|
|
|
if($@ eq "")
|
|
{
|
|
return $self;
|
|
}
|
|
elsif($@ !~ m/Couldn't open X11 display/)
|
|
{
|
|
last;
|
|
}
|
|
|
|
note("DOSBox startup failed, trying again.");
|
|
note("Error was:\n$@");
|
|
|
|
$self->_stop();
|
|
}
|
|
|
|
die $@;
|
|
}
|
|
|
|
sub _start
|
|
{
|
|
my ($self, $port) = @_;
|
|
|
|
my $dosbox_conf = File::Temp->new();
|
|
print {$dosbox_conf} <<EOF;
|
|
[ipx]
|
|
ipx=true
|
|
|
|
[autoexec]
|
|
ipxnet startserver $port
|
|
EOF
|
|
|
|
my @command = ("xvfb-run", "-a", "-e" => "/dev/stdout",
|
|
"stdbuf", "-i0", "-o0", "-e0",
|
|
"dosbox", "-conf" => "$dosbox_conf");
|
|
|
|
note(join(" ", @command));
|
|
|
|
# No need for error checking here - open3 throws on failure.
|
|
$self->{xvfb_run_pid} = open3(my $in, my $out, undef, @command);
|
|
|
|
my $output = "";
|
|
|
|
# Read from child until we see what we expected or the pipe gets closed.
|
|
while($output !~ m/^IPX: Connected to server\./m && defined(my $line = <$out>))
|
|
{
|
|
$output .= $line;
|
|
}
|
|
|
|
# We can't kill DOSBox by sending a signal to xvfb-run since it doesn't
|
|
# catch any signals and just dies, leaving orphan Xvfb and dosbox processes
|
|
# running.
|
|
#
|
|
# So we have to walk the process table and find the dosbox process owned by
|
|
# our xvfb-run process, which we can then directly kill and xvfb-run will
|
|
# clean up the Xvfb instance.
|
|
|
|
my @procs = @{ Proc::ProcessTable->new()->table() };
|
|
|
|
my $find_dosbox = sub
|
|
{
|
|
my ($find_dosbox, $ppid) = @_;
|
|
|
|
foreach my $child(grep { $_->ppid() == $ppid } @procs)
|
|
{
|
|
# if($child->cmdline->[0] eq "dosbox")
|
|
if($child->cmndline =~ m/^dosbox /)
|
|
{
|
|
return $child->pid;
|
|
}
|
|
|
|
my $dosbox_pid = $find_dosbox->($find_dosbox, $child->pid);
|
|
return $dosbox_pid if(defined $dosbox_pid);
|
|
}
|
|
|
|
return;
|
|
};
|
|
|
|
$self->{dosbox_pid} = $find_dosbox->($find_dosbox, $self->{xvfb_run_pid});
|
|
|
|
if($output =~ m/^IPX: Connected to server\./m)
|
|
{
|
|
die "Couldn't find DOSBox PID - did it crash?" unless(defined $self->{dosbox_pid});
|
|
return;
|
|
}
|
|
|
|
die "Didn't get expected output from xvfb-run/dosbox:\n$output";
|
|
}
|
|
|
|
sub _stop
|
|
{
|
|
my ($self) = @_;
|
|
|
|
# Kill DOSBox, then wait for xvfb-run to clean up.
|
|
|
|
kill(SIGTERM, $self->{dosbox_pid}) if(defined $self->{dosbox_pid});
|
|
waitpid($self->{xvfb_run_pid}, 0) if(defined $self->{xvfb_run_pid});
|
|
|
|
$self->{dosbox_pid} = undef;
|
|
$self->{xvfb_run_pid} = undef;
|
|
}
|
|
|
|
sub DESTROY
|
|
{
|
|
my ($self) = @_;
|
|
|
|
$self->_stop();
|
|
}
|
|
|
|
1;
|