Re: [PATCH qemu-server 1/6] tests: hotplug: add initial hotplug test harness

[Fiona Ebner <f.ebner@proxmox.com>]

Am 10.09.26 um 1:09 PM schrieb Dominik Csapak:
> diff --git a/src/test/CommandLineMocks.pm b/src/test/CommandLineMocks.pm
> new file mode 100644
> index 00000000..a5883073
> --- /dev/null
> +++ b/src/test/CommandLineMocks.pm
> @@ -0,0 +1,556 @@
> +package CommandLineMocks;
> +
> +# Mocks for generating the QEMU command line of a VM config in tests, shared
> +# between the test scripts for the command line itself and for hotplugging. The
> +# environment (storage configuration, PCI devices, mappings, ...) is fixed,
> +# while a few properties of the host can be set per test via set_test_env().
> +# Also contains helpers that are useful and needed by multiple test harnesses.
> +
> +use v5.36;
> +

Missing include for File::Temp used by diff(), but I'm suggesting moving
that to its own module, see below.

> +use JSON qw(decode_json);
> +use Socket qw(AF_INET AF_INET6);
> +use Test::MockModule;
> +
> +use PVE::INotify;
> +use PVE::Mapping::PCI;
> +use PVE::Mapping::USB;
> +use PVE::ProcFSTools;
> +use PVE::QemuServer::CPUConfig;
> +use PVE::QemuServer::Drive;
> +use PVE::QemuServer::Helpers;
> +use PVE::QemuServer::Memory;
> +use PVE::QemuServer::OVMF;
> +use PVE::QemuServer::PCI;
> +use PVE::QemuServer;
> +use PVE::Storage::RBDPlugin;
> +use PVE::Storage::ZFSPlugin;
> +use PVE::Storage;
> +use PVE::SysFSTools;
> +use PVE::Tools qw(run_command);
> +
> +use base 'Exporter';
> +
> +our @EXPORT_OK = qw(
> +    get_storage_config
> +    get_test_qemu_version
> +    set_test_env
> +    diff
> +);
> +
> +my $real_qemu_version = PVE::QemuServer::Helpers::kvm_user_version(); # not yet mocked

I know this is copied, but I think we should remove the comment.
Individual tests can already mock the binary version and for the others,
we do intentionally use the installed QEMU binary to see changes.

> +
> +# the properties of the host for the current test, see set_test_env()
> +my $test_env = {};
> +
> +# The mocker objects need to stay alive for the mocks to stay in effect. File-scoped lexicals of a
> +# module are freed after loading it, so package variables are used for them.

I'd move this comment to below where the mock objects are defined. Maybe
also mention that this is about the 'our'.

---snip 8<---

> +sub diff($expected, $got) {
> +    return if $expected eq $got;
> +
> +    my $tmp = File::Temp->new();
> +    print $tmp $expected;
> +    $tmp->flush();
> +
> +    my $diff = '';
> +    run_command(
> +        ['diff', '-up', '--label', 'expected', $tmp->filename(), '--label', 'got', '-'],
> +        input => $got,
> +        outfunc => sub { $diff .= "$_[0]\n"; },
> +        noerr => 1,
> +    );
> +
> +    return $diff;
> +}
The diff helper might be even better in a dedicated module. Could also
be re-used by run_parse_config_tests.pl then and avoid writing the
output file there.

---snip 8<---

> diff --git a/src/test/run_hotplug_tests.pl b/src/test/run_hotplug_tests.pl
> new file mode 100644
> index 00000000..0cfeb350
> --- /dev/null
> +++ b/src/test/run_hotplug_tests.pl
> @@ -0,0 +1,780 @@
> +#!/usr/bin/perl
> +
> +# Regression tests for applying pending changes to a running VM via hotplug.
> +#
> +# Each test is a VM config in 'hotplug/*.conf' with the changes to apply in a [PENDING] section. The
> +# monitor of the VM is mocked with a minimal model of a running QEMU instance, that tracks the
> +# present devices, buses, block nodes, backends and QOM objects and enforces the constraints between
> +# them. Every monitor command and every host-side action (network, SDN, storage, cgroup) that is
> +# issued while applying the pending changes is recorded. Afterwards, the model is compared to the
> +# model of a VM freshly started with the resulting config, which is what the target of a live
> +# migration is, to detect deviations like differing PCI addresses or left-over devices. The
> +# recording, the resulting hotplug errors, the differences and the resulting VM config are compared
> +# to the corresponding 'hotplug/*.conf.expected' file. If that file does not exist yet, it is
> +# generated and needs to be manually verified. Tests for an aarch64 host are in 'hotplug/aarch64/'.
> +
> +use v5.36;
> +
> +use lib qw(.. .);
> +
> +# the hotplug helpers wait between retries when verifying (un)plugged devices, do not wait in tests
> +BEGIN {
> +    *CORE::GLOBAL::sleep = sub { return 0; };
> +}

Why is this necessary in the tests? We control whether adding or
removing a device works in the tests, so I feel like this sweeps
something under the rug that we could improve in qemu-server. Does
qemu-server (sometimes) call {add,del}verify() when {add,del}() failed?

> +
> +use JSON;
> +use Storable qw(dclone);
> +use Test::More;
> +use Test::MockModule;
> +
> +use PVE::File qw(file_get_contents file_set_contents);
> +use PVE::QemuConfig;
> +use PVE::QemuServer;
> +use PVE::QemuServer::Blockdev;
> +use PVE::QemuServer::CGroup;
> +use PVE::QemuServer::CPUConfig;
> +use PVE::QemuServer::Drive;
> +use PVE::QemuServer::DriveDevice;
> +use PVE::QemuServer::Helpers;
> +use PVE::QemuServer::Machine;
> +use PVE::QemuServer::Monitor;
> +use PVE::QemuServer::Network;
> +use PVE::Storage;

Nit: does not follow the style guide:
https://pve.proxmox.com/wiki/Perl_Style_Guide#Module_Dependencies

> +
> +# the mocks for generating the command line of a VM, shared with the cfg2cmd tests
> +use CommandLineMocks qw(get_storage_config get_test_qemu_version set_test_env diff);
> +
> +my $vmid = 8006;
> +my $fake_config_fn = "hotplug/qemu-server/$vmid.conf";
> +
> +my $storecfg = get_storage_config();
> +
> +my $current_test; # = {
> +#   testname => 'file name and description',
> +#   description => 'Test description', # if available
> +#   qemu_version => '10.1',
> +#   host_arch => 'x86_64',
> +#   fail_device_add => { deviceid => 1 },
> +#   fail_device_del => { deviceid => 1 },
> +#   fail_command => { command => 1 },
> +#   config => { config hash },
> +# };
> +
> +# The model of the running QEMU instance, set up from the command line that config_to_command()
> +# generates for the config. The number of online vCPUs and the present memory DIMMs are derived
> +# from the 'cpuN' and 'dimmN' devices. Buses are derived from the machine type and the present
> +# bridges and controllers.
> +my $vm_state; # = {
> +#   machine => 'pc-i440fx-10.1+pve0', # the machine type of the running VM
> +#   buses => { bus => 1 }, # buses provided by the machine itself
> +#   devices => { qdev_id => { device options referencing buses and backends } },
> +#   hotplugged => { qdev_id => 1 }, # devices that were added during the test
> +#   netdevs => { netdev_id => 1 },
> +#   chardevs => { chardev_id => 1 },
> +#   drives => { drive_id => 1 }, # legacy '-drive' backends (machine version < 10.0)
> +#   blocknodes => { node_name => 1 }, # explicitly added block nodes (machine version >= 10.0)
> +#   objects => { object_id => { arguments of object-add } }, # QOM objects
> +# };
> +
> +my $log; # all recorded actions of the current test

$recorded_actions = []; ?

> +
> +# use the config description to describe the test and the state of the running VM, fields are:
> +#   TEST: A single line describing the test, gets outputted
> +#   QEMU_VERSION: \d+\.\d+(\.\d+)? version of the running QEMU binary (defaults to current version)
> +#   HOST_ARCH: x86_64 | aarch64 (default to x86_64, to make tests stable)
> +#   FAIL_DEVICE_ADD: <id> QEMU accepts 'device_add' for this device, but it never shows up
> +#   FAIL_DEVICE_DEL: <id> QEMU accepts 'device_del' for this device, but it never goes away
> +#   FAIL_COMMAND: <name> the QMP or HMP command with this name fails
> +# all fields are optional, the last three can be specified multiple times
> +sub parse_test($config_fn) {
> +    $current_test = {
> +        fail_device_add => {},
> +        fail_device_del => {},
> +        fail_command => {},
> +    };
> +
> +    my $config_raw = file_get_contents($config_fn);
> +    my $config = PVE::QemuServer::parse_vm_config($fake_config_fn, $config_raw);
> +
> +    $current_test->{config} = $config;
> +
> +    my $description = $config->{description} // '';
> +
> +    while ($description =~ /^\h*(.*?)\h*$/gm) {
> +        my $line = $1;
> +        next if !$line || $line =~ /^#/;
> +
> +        if ($line =~ /^TEST:\s*(.*)\s*$/) {
> +            $current_test->{description} = "$1";
> +        } elsif ($line =~ /^QEMU_VERSION:\s*(.*)\s*$/) {
> +            $current_test->{qemu_version} = "$1";
> +        } elsif ($line =~ /^HOST_ARCH:\s*(.*)\s*$/) {
> +            $current_test->{host_arch} = "$1";
> +        } elsif ($line =~ /^FAIL_DEVICE_ADD:\s*(\S+)\s*$/) {
> +            $current_test->{fail_device_add}->{$1} = 1;
> +        } elsif ($line =~ /^FAIL_DEVICE_DEL:\s*(\S+)\s*$/) {
> +            $current_test->{fail_device_del}->{$1} = 1;
> +        } elsif ($line =~ /^FAIL_COMMAND:\s*(\S+)\s*$/) {
> +            $current_test->{fail_command}->{$1} = 1;
> +        }
> +    }
> +
> +    # the description only describes the test and is not part of the resulting config
> +    delete $config->{description};
> +
> +    $config_fn =~ /([^\/]+)$/;
> +    my $testname = "$1";
> +    if (my $desc = $current_test->{description}) {
> +        $testname = "'$testname' - $desc";
> +    }
> +    $current_test->{testname} = $testname;
> +
> +    set_test_env($current_test);
> +
> +    # the 'host' CPU model is registered for the host architecture of the current test
> +    PVE::QemuServer::CPUConfig::initialize_cpu_models();
> +}
> +
> +# The buses a machine provides on its own. Everything else (PCI bridges, SCSI and USB controllers)
> +# comes from devices on the command line or from the config files read via -readconfig.
> +sub machine_buses($conf, $machine) {

default_buses_for_machine(). Can't we somehow get this from qemu-server?
I'd like to avoid the need to duplicate/hard-code this here.

> +    return { map { $_ => 1 } qw(pcie.0) } if $machine =~ m/^virt/;
> +    return { map { $_ => 1 } ('pcie.0', map { "ide.$_" } 0 .. 5) }
> +        if PVE::QemuServer::Machine::machine_type_is_q35($conf);
> +    return { map { $_ => 1 } qw(pci.0 ide.0 ide.1) };
> +}
> +
> +# Parse a comma separated option string like 'driver,id=x,bus=y' into a hash. A leading value
> +# without key is stored under $first_key.
> +sub parse_options($string, $first_key = undef) {
> +    my $options = {};
> +    for my $part (split(/,/, $string)) {
> +        if ($part =~ m/^([^=]+)=(.*)$/) {
> +            $options->{$1} = $2;
> +        } elsif (defined($first_key)) {
> +            $options->{$first_key} = $part;
> +        }
> +    }
> +    return $options;
> +}
> +
> +# Parse the devices from a QEMU config file (-readconfig), which is shipped in 'usr/' of the repo.
> +sub parse_readconfig($path) {
> +    my ($name) = $path =~ m|([^/]+)$|;
> +    my $devices = {};
> +    my $current;
> +    for my $line (split(/\n/, file_get_contents("../usr/$name"))) {
> +        if ($line =~ m/^\[device "([^"]+)"\]/) {
> +            $current = $devices->{$1} = { id => $1 };
> +        } elsif ($line =~ m/^\[/) {
> +            $current = undef;
> +        } elsif ($current && $line =~ m/^\s*(\S+)\s*=\s*"([^"]*)"/) {
> +            $current->{$1} = $2;
> +        }
> +    }
> +    return $devices;
> +}
> +
> +# QEMU resolves the unversioned aliases 'pc', 'q35' and 'virt' to the versioned default machine of
> +# the running binary, which is also what query-machines reports for the running VM. The pve version
> +# is kept as it was requested on the command line.
> +sub resolve_machine_alias($machine) {

Can't you use the windows_get_pinned_machine_version() function here?
I'd like to avoid duplicate fucntions for things that already exist. We
could also drop the 'windows_' prefix if we want, the function itself is
not concerned with that, we just use it only for Windows.

> +    my ($type, $pve_version) = split(/\+/, $machine, 2);
> +    my $aliases = { pc => 'pc-i440fx', q35 => 'pc-q35', virt => 'virt' };
> +    if (my $prefix = $aliases->{$type}) {
> +        my ($version) = get_test_qemu_version() =~ m/^(\d+\.\d+)/;
> +        $type = "$prefix-$version";
> +    }
> +    return defined($pve_version) ? "$type+$pve_version" : $type;
> +}
> +
> +# Returns the model of a VM freshly started with the given config, derived from the command line
> +# that config_to_command() generates for it.
> +sub vm_state_from_config($conf) {
> +    my $cmd = PVE::QemuServer::config_to_command(
> +        $storecfg, $vmid, dclone($conf), PVE::QemuServer::load_defaults(), {},
> +    );
> +
> +    my $state = {
> +        machine => resolve_machine_alias(PVE::QemuServer::Machine::get_vm_machine($conf)),
> +        devices => {},
> +        hotplugged => {},
> +        netdevs => {},
> +        chardevs => {},
> +        drives => {},
> +        blocknodes => {},
> +        objects => {},
> +    };

I don't like that we need to try to re-implement QEMU comamndline
parsing, even if with reduced scope :/ Ideally, we could get the
collected info from cfg2cmd before it prints it out. But yeah, we are
not there yet..

> +
> +    for (my $i = 0; $i < scalar($cmd->@*) - 1; $i++) {
> +        my ($opt, $arg) = $cmd->@[$i, $i + 1];
> +        if ($opt eq '-machine') {
> +            $state->{machine} = resolve_machine_alias(parse_options($arg)->{type});
> +        } elsif ($opt eq '-device') {
> +            my $device = parse_options($arg, 'driver');
> +            $state->{devices}->{ $device->{id} } = $device if $device->{id};
> +        } elsif ($opt eq '-readconfig') {
> +            my $devices = parse_readconfig($arg);
> +            $state->{devices}->{$_} = $devices->{$_} for keys $devices->%*;
> +        } elsif ($opt eq '-netdev') {
> +            $state->{netdevs}->{ parse_options($arg)->{id} } = 1;
> +        } elsif ($opt eq '-chardev') {
> +            $state->{chardevs}->{ parse_options($arg, 'backend')->{id} } = 1;
> +        } elsif ($opt eq '-drive') {
> +            $state->{drives}->{ parse_options($arg)->{id} } = 1;
> +        } elsif ($opt eq '-blockdev') {
> +            $state->{blocknodes}->{ decode_json($arg)->{'node-name'} } = 1;
> +        } elsif ($opt eq '-object') {
> +            my $object = $arg =~ m/^\{/ ? decode_json($arg) : parse_options($arg, 'qom-type');
> +            # sizes on the command line have a unit, QMP uses bytes
> +            if (defined($object->{size}) && $object->{size} =~ m/^(\d+)([MG])$/) {
> +                $object->{size} = $1 * 1024 * 1024 * ($2 eq 'G' ? 1024 : 1);
> +            }
> +            $state->{objects}->{ $object->{id} } = $object;
> +        }
> +    }
> +
> +    $state->{buses} = machine_buses($conf, $state->{machine});
> +
> +    return $state;
> +}
> +
> +sub setup_vm_state($conf) {
> +    $vm_state = vm_state_from_config($conf);
> +}
> +
> +# Throttle limits set via QMP contain all properties, while the throttle group generated for the
> +# command line only contains the configured ones. Drop the defaults to make them comparable.
> +sub normalized_object($object) {

Nit: Name is a bit confusing in the sense that it only does something
for the very specific throttle-group case. We could also inject the
implicit defaults when we extract the info from the commandline. But no
big deal.

> +    $object = dclone($object);
> +    if (($object->{'qom-type'} // '') eq 'throttle-group' && $object->{limits}) {
> +        my $limits = $object->{limits};
> +        my $is_default = sub { $limits->{ $_[0] } == ($_[0] =~ m/-max-length$/ ? 1 : 0) };
> +        $object->{limits} =
> +            { map { $_ => $limits->{$_} } grep { !$is_default->($_) } keys %$limits };
> +    }
> +    return to_json($object, { canonical => 1 });
> +}
> +
> +# Compare the model of the running VM with the model of a VM freshly started with the resulting
> +# config, like the target of a live migration is. Returns a list of the differences. The boot index
> +# is not compared, as hotplugged devices are added without one.
> +sub compare_with_fresh_vm($conf) {
> +    my $running = $vm_state;
> +    my $fresh = vm_state_from_config($conf);
> +    my @differences = ();
> +
> +    my $compare_ids = sub {
> +        my ($kind, $running_ids, $fresh_ids) = @_;
> +        my $only_in = sub {
> +            my ($ids, $others, $desc) = @_;
> +            push @differences, "$kind $_: only present in $desc"
> +                for sort grep { !$others->{$_} } keys $ids->%*;
> +        };
> +        $only_in->($running_ids, $fresh_ids, 'running VM');
> +        $only_in->($fresh_ids, $running_ids, 'freshly started VM');

Style nit: I think this is hard to read. Maybe collect the keys from
both and then do a normal loop?

> +    };
> +
> +    push @differences, "machine: running '$running->{machine}' vs fresh '$fresh->{machine}'"
> +        if $running->{machine} ne $fresh->{machine};
> +
> +    $compare_ids->('device', $running->{devices}, $fresh->{devices});
> +    for my $id (sort grep { $fresh->{devices}->{$_} } keys $running->{devices}->%*) {
> +        my $running_device = $running->{devices}->{$id};
> +        my $fresh_device = $fresh->{devices}->{$id};
> +        my %options = map { $_ => 1 } keys $running_device->%*, keys $fresh_device->%*;
> +        delete $options{bootindex};
> +        for my $option (sort keys %options) {
> +            my $running_value = $running_device->{$option} // '<undef>';
> +            my $fresh_value = $fresh_device->{$option} // '<undef>';
> +            push @differences,
> +                "device $id option $option: running '$running_value' vs fresh '$fresh_value'"
> +                if "$running_value" ne "$fresh_value";
> +        }
> +    }
> +
> +    $compare_ids->('object', $running->{objects}, $fresh->{objects});
> +    for my $id (sort grep { $fresh->{objects}->{$_} } keys $running->{objects}->%*) {
> +        my $running_object = normalized_object($running->{objects}->{$id});
> +        my $fresh_object = normalized_object($fresh->{objects}->{$id});
> +        push @differences, "object $id: running $running_object vs fresh $fresh_object"
> +            if $running_object ne $fresh_object;
> +    }
> +
> +    for my $kind (qw(netdev chardev drive blocknode)) {
> +        $compare_ids->($kind, $running->{"${kind}s"}, $fresh->{"${kind}s"});
> +    }
> +
> +    return @differences;
> +}
> +
> +# Record an action with its arguments. HMP commands are recorded as the full command line. Arguments
> +# of QMP commands are recorded as they are, for other actions all scalars are stringified to be
> +# independent from the internal representation.
> +sub record($layer, $action, @args) {

record_action()

It seems the difference is that for QMP additional args are discarded.
So not sure about the recorded as they are and what the comment about
the distinction with stringification means?

Maybe there should be a dedicated helper for QMP if the signature is
de-facto different rather than overloading it.

> +    my $line = "$layer $action";
> +    if ($layer eq 'qmp') {
> +        $line .= ' ' . to_json($args[0], { canonical => 1 });
> +    } elsif (scalar(@args)) {
> +        $line .= ' ' . to_json([@args], { canonical => 1 });
> +    }
> +    push $log->@*, $line;
> +}
> +
> +sub sorted_devices($regex = qr/./) {
> +    return sort grep { $_ =~ $regex } keys $vm_state->{devices}->%*;

perlcritic complains:
"return" statement followed by "sort" at line 325, column 5.  Behavior
is undefined if called in scalar context.  (Severity: 5)

> +}
> +
> +# Returns the ID of a device referencing the given backend via the given device option.
> +sub device_using($option, $value) {

Nit: maybe call it device_using_backend($type, $id)? We probably also
want to extract the types of backends out of add_device() and check that
it's one of these.

Looking at the callers, an assert_backend_is_not_in_use() might be a
better fit.

> +    my $devices = $vm_state->{devices};
> +    my @users = grep { ($devices->{$_}->{$option} // '') eq $value } sort keys $devices->%*;
> +    return $users[0];
> +}
> +
> +sub bus_exists($bus) {

bus_exists_in_vm_state

> +    return 1 if $vm_state->{buses}->{$bus};
> +    return 1 if $bus =~ m/^pci\.\d+$/ && $vm_state->{devices}->{$bus}; # PCI bridge
> +    return 1 if $bus =~ m/^(.+)\.0$/ && $vm_state->{devices}->{$1}; # SCSI and USB controllers
> +    return 0;
> +}
> +
> +# Check the constraints for adding the device with the given options. Returns an error message if
> +# the device cannot be added, otherwise adds it and returns nothing.
> +sub add_device($options) {

Nit: I feel the signature with returning an error as a string instead of
die-ing a bit strange. And there is still a 'die' in the very first
line, so it's not consistent.

> +    my $id = $options->{id} or die "device_add without ID\n";
> +    my $driver = $options->{driver};
> +
> +    return "Duplicate device ID '$id'" if $vm_state->{devices}->{$id};
> +    return "simulated failure adding device '$id'" if $current_test->{fail_device_add}->{$id};
> +

---snip 8<---

> +# QMP commands that do not change the modeled state of the VM
> +my $stateless_commands = {

$qmp_command_does_not_change_state

> +    map { $_ => 1 }
> +        qw(
> +        balloon
> +        block_set_io_throttle
> +        blockdev-change-medium
> +        blockdev-close-tray
> +        blockdev-open-tray
> +        eject
> +        )
> +};

Sytle nit: I'd avoid the map and just have one 'key => 1,' per line like
usual for prettier indentation.

> +
> +# Replacement for PVE::QemuServer::Monitor::qmp_cmd, handling all monitor communication with the VM.
> +sub fake_qmp_cmd {

Nit: I'd prefer s/fake/mocked/, also for the other functions.

> +    my ($peer, $execute, %arguments) = @_;
> +
> +    die "unexpected QMP peer '$peer->{name}' of type '$peer->{type}'\n"
> +        if $peer->{type} ne 'qmp' || $peer->{id} != $vmid;
> +
> +    delete $arguments{timeout};
> +    my $noerr = delete $arguments{noerr};
> +
> +    return fake_hmp_cmd($arguments{'command-line'}) if $execute eq 'human-monitor-command';
> +
> +    # queries do not change the state of the VM and are not recorded
> +    if (my $result = fake_qmp_query($execute, \%arguments)) {
> +        return $result;
> +    }
> +
> +    record('qmp', $execute, \%arguments);
> +
> +    my $fail = sub {
> +        my ($msg) = @_;
> +        return { error => $msg } if $noerr;
> +        die "$msg\n";
> +    };

Alternatively, there could be a wrapper, so you could regularly die in
the actual implementation and the wrapper translates it later. This
would avoid the unusual 'return $fail->()' pattern to improve readability.

> +
> +    return $fail->("simulated failure of QMP command '$execute'")
> +        if $current_test->{fail_command}->{$execute};
> +
> +    return {} if $stateless_commands->{$execute};
> +
> +    my $id = $arguments{id};
> +    my $node_name = $arguments{'node-name'};
> +    my $devices = $vm_state->{devices};
> +
> +    if ($execute eq 'device_add') { # the QMP variant is only used for memory DIMMs

Right now, but this comment will just get outdated when it changes. Is
there a special rationale for adding it?

> +        my $err = add_device(\%arguments);
> +        return $fail->($err) if $err;
> +    } elsif ($execute eq 'netdev_add') {
> +        return $fail->("Duplicate ID '$id' for netdev") if $vm_state->{netdevs}->{$id};
> +        $vm_state->{netdevs}->{$id} = 1;
> +    } elsif ($execute eq 'netdev_del') {
> +        return $fail->("Device '$id' not found") if !$vm_state->{netdevs}->{$id};
> +        if (my $device = device_using('netdev', $id)) {
> +            return $fail->("netdev '$id' is in use by device '$device'");
> +        }
> +        delete $vm_state->{netdevs}->{$id};
> +    } elsif ($execute eq 'set_link') {
> +        my $name = $arguments{name};
> +        return $fail->("Device '$name' not found")
> +            if !$devices->{$name} && !$vm_state->{netdevs}->{$name};
> +    } elsif ($execute eq 'chardev-add') {
> +        return $fail->("Duplicate ID '$id' for chardev") if $vm_state->{chardevs}->{$id};
> +        $vm_state->{chardevs}->{$id} = 1;
> +    } elsif ($execute eq 'object-add') {
> +        return $fail->("Duplicate object ID '$id'") if $vm_state->{objects}->{$id};
> +        $vm_state->{objects}->{$id} = \%arguments;
> +    } elsif ($execute eq 'object-del') {
> +        return $fail->("Object '$id' not found") if !$vm_state->{objects}->{$id};
> +        for my $option (qw(iothread memdev)) {
> +            if (my $device = device_using($option, $id)) {
> +                return $fail->("Object '$id' is in use by device '$device'");
> +            }
> +        }
> +        # the top block node of a drive uses the throttle group with the same name
> +        if (my ($node) = $id =~ m/^throttle-(drive-.+)$/) {
> +            return $fail->("Object '$id' is in use by node '$node'")
> +                if $vm_state->{blocknodes}->{$node};
> +        }
> +        delete $vm_state->{objects}->{$id};
> +    } elsif ($execute eq 'qom-set') { # only used for the limits of throttle groups

Same as above. Right now it's only used for that. But this comment will
just get outdated when that changes.

> +        my $object = $vm_state->{objects}->{ $arguments{path} }
> +            or return $fail->("Object '$arguments{path}' not found");
> +        $object->{ $arguments{property} } = $arguments{value};
> +    } elsif ($execute eq 'blockdev-add') {
> +        return $fail->("Duplicate nodes with node-name='$node_name'")
> +            if $vm_state->{blocknodes}->{$node_name};
> +        $vm_state->{blocknodes}->{$node_name} = 1;
> +    } elsif ($execute eq 'blockdev-del') {
> +        return $fail->("Failed to find node with node-name='$node_name'")
> +            if !$vm_state->{blocknodes}->{$node_name};
> +        if (my $device = device_using('drive', $node_name)) {
> +            return $fail->("Node '$node_name' is in use by device '$device'");
> +        }
> +        delete $vm_state->{blocknodes}->{$node_name};
> +    } elsif ($execute eq 'blockdev-remove-medium') {
> +        return $fail->("Device '$id' not found") if !$devices->{$id};
> +        delete $devices->{$id}->{drive};
> +    } elsif ($execute eq 'blockdev-insert-medium') {
> +        return $fail->("Device '$id' not found") if !$devices->{$id};
> +        return $fail->("Node '$node_name' not found") if !$vm_state->{blocknodes}->{$node_name};
> +        $devices->{$id}->{drive} = $node_name;
> +    } else {
> +        die "unexpected QMP command: '$execute'\n";
> +    }
> +
> +    return {};
> +}
> +
> +my $monitor_module = Test::MockModule->new('PVE::QemuServer::Monitor');
> +$monitor_module->mock(qmp_cmd => \&fake_qmp_cmd);
> +
> +# qmp_cmd is imported by these modules, so the imported copies need to be replaced too
> +my $qemu_server_module = Test::MockModule->new('PVE::QemuServer');
> +$qemu_server_module->mock(qmp_cmd => \&fake_qmp_cmd);
> +
> +my $blockdev_module = Test::MockModule->new('PVE::QemuServer::Blockdev');
> +$blockdev_module->mock(qmp_cmd => \&fake_qmp_cmd);
> +
> +# the machine type of the running VM is derived from the QEMU version, so it has to be the mocked
> +# one everywhere, not only for the imported copy in PVE::QemuServer
> +my $qemu_server_helpers = Test::MockModule->new('PVE::QemuServer::Helpers');
> +$qemu_server_helpers->mock(
> +    kvm_user_version => \&get_test_qemu_version,
> +    vm_running_locally => sub {
> +        return 1;
> +    },
> +);
> +
> +my $drive_device_module = Test::MockModule->new('PVE::QemuServer::DriveDevice');
> +$drive_device_module->mock(kvm_user_version => \&get_test_qemu_version);
> +
> +my $qemu_server_config = Test::MockModule->new('PVE::QemuConfig');
> +$qemu_server_config->mock(
> +    write_config => sub {
> +        my ($class, $vmid, $conf) = @_;
> +        return;
> +    },

The test does not model reality anymore if there ever is a write
followed by a load. Should we mock load_config and die there, so we
notice (or if necessary remember the written config in a variable)?

> +);
> +