[pve-devel] [PATCH pve-common v1 02/23] tests: sectionconfig: add comparison test structure

["Max R. Carrara" <m.carrara@proxmox.com>]

During development, I spotted a couple interesting "peculiarities"
when it comes to the schemas that PVE::SectionConfig generates.
I was initially intending to document these cases textually (as part
of the PVE::SectionConfig docs), but quickly realized that it's a
better idea to document these cases as unit / regression tests.

Therefore, set up a new test directory specifically for
PVE::SectionConfig and add `schema_comparison_test.pl`. The latter
contains a setup that allows us to write declarative tests for
SectionConfig in the form of nested packages:

- Each "test package" is based on the top-level `TestPackage`

- Inside such a test package, a PVE::SectionConfig plugin structure
  must be declared (i.e. base plugin and child plugins)

- The create and update schemas of each plugin structure inside a
  test package are then compared against their expected outputs,
  which are also declared inside the test package

- this is done for both unified and isolated modes without the need to
  define separate packages for either mode

In other words, to add a new test case, one has to only define a test
package, add a PVE::SectionConfig plugin structure inside of it, and
then declare the expected outputs for the schemas.

To run the tests, find all of the child packages of `TestPackage`
inside `main` (the test script) and run a subroutine for it that sets
up and tears down the plugin structure for unified and isolated mode.

Should a test fail, the contents of the gotten and expected schemas
are printed to the console in a human-readable format using
Data::Dumper, with some customized parameters. This should make it
rather easy to spot any discrepancies in case a test breaks.

Finally, add a basic test case checking that properties added by child
plugins are always optional, even if they're declared as non-optional,
both to document the first "interesting fact" about SectoinConfig and
also in order to actually show how test cases are added.

Signed-off-by: Max R. Carrara <m.carrara@proxmox.com>
---
 test/Makefile                                |   5 +-
 test/SectionConfig/Helpers.pm                | 114 +++++++
 test/SectionConfig/Makefile                  |  10 +
 test/SectionConfig/schema_comparison_test.pl | 322 +++++++++++++++++++
 4 files changed, 450 insertions(+), 1 deletion(-)
 create mode 100644 test/SectionConfig/Helpers.pm
 create mode 100644 test/SectionConfig/Makefile
 create mode 100755 test/SectionConfig/schema_comparison_test.pl

diff --git a/test/Makefile b/test/Makefile
index 5b690c4..9b9f81b 100644
--- a/test/Makefile
+++ b/test/Makefile
@@ -1,4 +1,7 @@
-SUBDIRS = etc_network_interfaces
+SUBDIRS = etc_network_interfaces	\
+	  SectionConfig			\
+
+
 TESTS = lock_file.test			\
 	calendar_event_test.test	\
 	convert_size_test.test		\
diff --git a/test/SectionConfig/Helpers.pm b/test/SectionConfig/Helpers.pm
new file mode 100644
index 0000000..970e0e4
--- /dev/null
+++ b/test/SectionConfig/Helpers.pm
@@ -0,0 +1,114 @@
+package SectionConfig::Helpers;
+
+use v5.36;
+
+use Data::Dumper;
+
+$Data::Dumper::Terse = 1;
+$Data::Dumper::Indent = 1;
+$Data::Dumper::Useqq = 1;
+$Data::Dumper::Deparse = 1;
+$Data::Dumper::Quotekeys = 0;
+$Data::Dumper::Sortkeys = 1;
+$Data::Dumper::Trailingcomma = 1;
+
+use base qw(Exporter);
+
+our @EXPORT_OK = qw(
+    get_symbol_table
+    symbol_table_has
+    get_subpackages
+    get_plugin_system_within_package
+    dump_symbol_table
+);
+
+our $UPDATE_SCHEMA_DEFAULT_PROPERTIES = {
+    digest => {
+        optional => 1,
+        type => 'string',
+        description => 'Prevent changes if current configuration file has a'
+            . ' different digest. This can be used to prevent concurrent'
+            . ' modifications.',
+        maxLength => 64,
+    },
+    delete => {
+        description => 'A list of settings you want to delete.',
+        maxLength => 4096,
+        format => 'pve-configid-list',
+        optional => 1,
+        type => 'string',
+    },
+};
+
+sub get_symbol_table($package) {
+    my $symbols = eval {
+        no strict 'refs'; ## no critic (ProhibitNoStrict)
+        *package_glob = *{"${package}::"};
+        my %syms = *package_glob->%*;
+        \%syms;
+    };
+
+    return $symbols;
+}
+
+sub symbol_table_has($package, $ref) {
+    my $symbols = get_symbol_table($package);
+    return defined($symbols->{$ref});
+}
+
+sub get_subpackages($package) {
+    my $symbols = get_symbol_table($package);
+
+    my $subpackages = [];
+
+    for my $symbol (keys $symbols->%*) {
+        if ($symbol =~ m/(?<name>.*)::$/) {
+            my $name = $+{name};
+            my $subpackage = "${package}::${name}";
+
+            my $is_class = eval { $subpackage->isa('UNIVERSAL') } || '';
+
+            push($subpackages->@*, $subpackage) if $is_class;
+        }
+    }
+
+    return $subpackages;
+}
+
+sub get_plugin_system_within_package($package) {
+    my $subpackages = get_subpackages($package);
+
+    my $base = undef;
+    my $plugins = [];
+
+    for my $package ($subpackages->@*) {
+        if ($package->isa('PVE::SectionConfig') && symbol_table_has($package, 'private')) {
+            $base = $package;
+            last;
+        }
+    }
+
+    for my $package ($subpackages->@*) {
+        if ($package->isa($base) && symbol_table_has($package, 'type')) {
+            push($plugins->@*, $package);
+        }
+    }
+
+    if (!defined($base)) {
+        die "failed to get plugin system within package '$package'";
+    }
+
+    return {
+        base => $base,
+        plugins => $plugins,
+    };
+}
+
+# debug aid
+sub dump_symbol_table($package) {
+    my $symbols = get_symbol_table($package);
+    print("'$package' => ", Dumper($symbols), "\n");
+    return;
+}
+
+1;
diff --git a/test/SectionConfig/Makefile b/test/SectionConfig/Makefile
new file mode 100644
index 0000000..d1c2b1a
--- /dev/null
+++ b/test/SectionConfig/Makefile
@@ -0,0 +1,10 @@
+TESTS = \
+	schema_comparison_test.pl				\
+
+
+all:
+
+.PHONY: check
+check: $(TESTS)
+	for TEST in $(TESTS); do perl $$TEST; done
+
diff --git a/test/SectionConfig/schema_comparison_test.pl b/test/SectionConfig/schema_comparison_test.pl
new file mode 100755
index 0000000..49f6bf7
--- /dev/null
+++ b/test/SectionConfig/schema_comparison_test.pl
@@ -0,0 +1,322 @@
+#!/usr/bin/perl
+
+use v5.36;
+
+use lib qw(
+    ..
+    ../../src/
+);
+
+use Data::Dumper;
+
+$Data::Dumper::Terse = 1;
+$Data::Dumper::Indent = 1;
+$Data::Dumper::Useqq = 1;
+$Data::Dumper::Deparse = 1;
+$Data::Dumper::Quotekeys = 0;
+$Data::Dumper::Sortkeys = 1;
+$Data::Dumper::Trailingcomma = 1;
+
+use Storable qw(dclone);
+
+use Test::More;
+
+use SectionConfig::Helpers qw(
+    symbol_table_has
+    get_subpackages
+    get_plugin_system_within_package
+    dump_symbol_table
+);
+
+package TestPackage {
+    use Carp qw(confess);
+
+    sub desc($class) {
+        return undef;
+    }
+
+    sub expected_unified_createSchema($class) {
+        confess "not implemented";
+    }
+
+    sub expected_unified_updateSchema($class) {
+        confess "not implemented";
+    }
+
+    sub expected_isolated_createSchema($class) {
+        confess "not implemented";
+    }
+
+    sub expected_isolated_updateSchema($class) {
+        confess "not implemented";
+    }
+};
+
+package OneOptionalNoCommon {
+    use base qw(TestPackage);
+
+    sub desc($class) {
+        return "properties added by plugins are always optional, "
+            . "even if they're marked as required";
+    }
+
+    package OneOptionalNoCommon::PluginBase {
+        use base qw(PVE::SectionConfig);
+
+        my $DEFAULT_DATA = {};
+
+        sub private($class) {
+            return $DEFAULT_DATA;
+        }
+    };
+
+    package OneOptionalNoCommon::PluginOne {
+        use base qw(OneOptionalNoCommon::PluginBase);
+
+        sub type($class) {
+            return 'one';
+        }
+
+        sub properties($class) {
+            return {
+                'prop-one' => {
+                    type => 'string',
+                    optional => 0,
+                },
+            };
+        }
+
+        sub options($class) {
+            return {
+                'prop-one' => {
+                    optional => 0,
+                },
+            };
+        }
+    };
+
+    package OneOptionalNoCommon::PluginTwo {
+        use base qw(OneOptionalNoCommon::PluginBase);
+
+        sub type($class) {
+            return 'two';
+        }
+
+        sub properties($class) {
+            return {
+                'prop-two' => {
+                    type => 'string',
+                    optional => 1,
+                },
+            };
+        }
+
+        sub options($class) {
+            return {
+                'prop-two' => {
+                    optional => 1,
+                },
+            };
+        }
+    };
+
+    sub expected_unified_createSchema($class) {
+        return {
+            type => 'object',
+            additionalProperties => 0,
+            properties => {
+                type => {
+                    type => 'string',
+                    enum => [
+                        "one", "two",
+                    ],
+                },
+                'prop-one' => {
+                    type => 'string',
+                    optional => 1,
+                },
+                'prop-two' => {
+                    type => 'string',
+                    optional => 1,
+                },
+            },
+        };
+    }
+
+    sub expected_unified_updateSchema($class) {
+        return {
+            type => 'object',
+            additionalProperties => 0,
+            properties => {
+                'prop-one' => {
+                    type => 'string',
+                    optional => 1,
+                },
+                'prop-two' => {
+                    type => 'string',
+                    optional => 1,
+                },
+                $SectionConfig::Helpers::UPDATE_SCHEMA_DEFAULT_PROPERTIES->%*,
+            },
+        };
+    }
+
+    sub expected_isolated_createSchema($class) {
+        return {
+            type => 'object',
+            additionalProperties => 0,
+            properties => {
+                type => {
+                    type => 'string',
+                    enum => [
+                        "one", "two",
+                    ],
+                },
+                'prop-one' => {
+                    'instance-types' => [
+                        "one",
+                    ],
+                    'type-property' => 'type',
+                    type => 'string',
+                    optional => 1,
+                },
+                'prop-two' => {
+                    'instance-types' => [
+                        "two",
+                    ],
+                    'type-property' => 'type',
+                    type => 'string',
+                    optional => 1,
+                },
+            },
+        };
+    }
+
+    sub expected_isolated_updateSchema($class) {
+        return {
+            type => 'object',
+            additionalProperties => 0,
+            properties => {
+                type => {
+                    type => 'string',
+                    enum => [
+                        "one", "two",
+                    ],
+                },
+                'prop-one' => {
+                    'instance-types' => [
+                        "one",
+                    ],
+                    'type-property' => 'type',
+                    type => 'string',
+                    optional => 1,
+                },
+                'prop-two' => {
+                    'instance-types' => [
+                        "two",
+                    ],
+                    'type-property' => 'type',
+                    type => 'string',
+                    optional => 1,
+                },
+                $SectionConfig::Helpers::UPDATE_SCHEMA_DEFAULT_PROPERTIES->%*,
+            },
+        };
+    }
+};
+
+sub test_compare_deeply($got, $expected, $test_name, $test_package) {
+    $test_name = "$test_package - $test_name";
+    my $description = $test_package->desc();
+
+    if (!is_deeply($got, $expected, $test_name)) {
+        note("\nDescription: ", $description // "(none)", "\n");
+        note("Got:");
+        note(Dumper($got));
+        note("Expected:");
+        note(Dumper($expected));
+        note("=" x 40);
+    }
+
+    return;
+}
+
+sub init_and_run_tests($package) {
+    my $system = get_plugin_system_within_package($package);
+
+    my ($base, $plugins) = $system->@{qw(base plugins)};
+
+    my $original_private_data = dclone($base->private());
+
+    # unified mode
+
+    for my $plugin ($plugins->@*) {
+        $plugin->register();
+    }
+
+    $base->init();
+
+    test_compare_deeply(
+        $base->createSchema(),
+        $package->expected_unified_createSchema(),
+        "unified - createSchema comparison",
+        $package,
+    );
+
+    test_compare_deeply(
+        $base->updateSchema(),
+        $package->expected_unified_updateSchema(),
+        "unified - updateSchema comparison",
+        $package,
+    );
+
+    # Reset private data so that we can just re-initialize the entire
+    # plugin architecture ad hoc
+    $base->private()->%* = $original_private_data->%*;
+
+    # isolated mode
+
+    for my $plugin ($plugins->@*) {
+        $plugin->register();
+    }
+
+    $base->init(property_isolation => 1);
+
+    test_compare_deeply(
+        $base->createSchema(),
+        $package->expected_isolated_createSchema(),
+        "isolated - createSchema comparison",
+        $package,
+    );
+
+    test_compare_deeply(
+        $base->updateSchema(),
+        $package->expected_isolated_updateSchema(),
+        "isolated - updateSchema comparison",
+        $package,
+    );
+
+    return;
+}
+
+sub main() {
+    my $subpackages = get_subpackages('main');
+
+    my $test_packages = [];
+
+    for my $package (sort $subpackages->@*) {
+        if ($package->isa('TestPackage') && $package !~ m/TestPackage/) {
+            push($test_packages->@*, $package);
+        }
+    }
+
+    for my $package ($test_packages->@*) {
+        init_and_run_tests($package);
+    }
+
+    done_testing();
+
+    return 0;
+}
+
+main();
-- 
2.47.3



_______________________________________________
pve-devel mailing list
pve-devel@lists.proxmox.com
https://lists.proxmox.com/cgi-bin/mailman/listinfo/pve-devel