feat: add full Zonemaster stack with Docker and Spanish UI
- Clone all 5 Zonemaster component repos (LDNS, Engine, CLI, Backend, GUI) - Dockerfile.backend: 8-stage multi-stage build LDNS→Engine→CLI→Backend - Dockerfile.gui: Astro static build served via nginx - docker-compose.yml: backend (internal) + frontend (port 5353) - nginx.conf: root redirects to /es/, /api/ proxied to backend - zonemaster-gui/config.ts: defaultLanguage set to 'es' (Spanish) Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
699
zonemaster-engine/t/TestUtil/DSL.pm
Normal file
699
zonemaster-engine/t/TestUtil/DSL.pm
Normal file
@@ -0,0 +1,699 @@
|
||||
package TestUtil::DSL;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use v5.24;
|
||||
|
||||
use Carp qw(confess croak);
|
||||
|
||||
use TestUtil::DSL::Compiler;
|
||||
|
||||
# This is needed in order to squelch “too late to run INIT block” warnings.
|
||||
use Zonemaster::Engine ();
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
TestUtil::DSL - a domain-specific language for easy testing of test cases
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Because this package lies in the testing directory C<t/>, which is not listed in C<@INC> during testing,
|
||||
it must be loaded using the following code:
|
||||
|
||||
use File::Basename qw( dirname );
|
||||
use File::Spec::Functions qw( rel2abs );
|
||||
use lib dirname( rel2abs( $0 ) );
|
||||
use TestUtil::DSL;
|
||||
|
||||
A test case can then be tested with the following minimal skeleton:
|
||||
|
||||
testing_test_case 'Example', 'example01';
|
||||
|
||||
all_tags qw(EX01_ALL_GOOD
|
||||
EX01_MINOR_ISSUE
|
||||
EX01_SOMETHING_WRONG
|
||||
EX01_SOME_OTHER_PROBLEM
|
||||
EX01_BREAKS_ON_SOME_FEATURE);
|
||||
|
||||
root_hints 'ns1' => [ qw(127.1.0.1 fda1:b2:c3::127:1:0:1) ],
|
||||
'ns2' => [ qw(127.1.0.2 fda1:b2:c3::127:1:0:2) ];
|
||||
zone_name_template '{SCENARIO}.{TESTCASE}.xa';
|
||||
|
||||
scenario 'GOOD-{1..3}' => sub {
|
||||
expect EX01_ALL_GOOD;
|
||||
};
|
||||
|
||||
# more scenarios here
|
||||
|
||||
no_more_scenarios;
|
||||
|
||||
=cut
|
||||
|
||||
use Exporter 'import';
|
||||
|
||||
our @EXPORT = qw(all_tags
|
||||
clear_cache
|
||||
expect
|
||||
expect_others
|
||||
fake_ds
|
||||
fake_ns
|
||||
forbid
|
||||
forbid_others
|
||||
no_more_scenarios
|
||||
not_testable
|
||||
root_hints
|
||||
scenario
|
||||
testing_test_case
|
||||
todo
|
||||
zone
|
||||
zone_name_template);
|
||||
|
||||
# Define a stack for internal context objects, some functions to manipulate it,
|
||||
# and only expose the top of the stack.
|
||||
{
|
||||
my @STACK = ();
|
||||
|
||||
sub STATE () {
|
||||
$STACK[-1];
|
||||
}
|
||||
|
||||
sub check_state ($) {
|
||||
my ($expected_state) = @_;
|
||||
|
||||
if (defined $expected_state) {
|
||||
if (scalar @STACK == 0 or $expected_state ne STATE->{_STATE}) {
|
||||
croak "This keyword is not valid in this context."
|
||||
}
|
||||
}
|
||||
elsif (scalar @STACK != 0) {
|
||||
croak "This keyword can only be used once";
|
||||
}
|
||||
}
|
||||
|
||||
sub pop_state {
|
||||
my $result = pop @STACK // croak "Attempted to pop empty stack";
|
||||
delete $result->{_STATE};
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub push_state ($) {
|
||||
push @STACK, { _STATE => $_[0] };
|
||||
}
|
||||
}
|
||||
|
||||
# Internal mechanics
|
||||
|
||||
sub _is_uint_bits {
|
||||
my ($value, $bits) = @_;
|
||||
return ($value =~ /^\d+$/a and $value >= 0 and $value < (1 << $bits));
|
||||
}
|
||||
|
||||
sub _expand_scenario_names {
|
||||
my @scenario_names = @_;
|
||||
my @result;
|
||||
|
||||
for my $name (@scenario_names) {
|
||||
if ($name=~ /^ (?<prefix> [^{]*) \{
|
||||
(?<start> \d+) \Q..\E (?<end> \d+)
|
||||
\} $ /x ) {
|
||||
for my $i ($+{start}..$+{end}) {
|
||||
push @result, "$+{prefix}$i";
|
||||
}
|
||||
}
|
||||
else {
|
||||
push @result, $name;
|
||||
}
|
||||
}
|
||||
|
||||
return @result;
|
||||
}
|
||||
|
||||
=head1 TOP-LEVEL KEYWORDS
|
||||
|
||||
=head2 all_tags
|
||||
|
||||
all_tags qw(SOME_TAG SOME_OTHER_TAG AND_ANOTHER_ONE);
|
||||
|
||||
List all the message tags that the test case being tested is expected to emit.
|
||||
|
||||
=cut
|
||||
|
||||
sub all_tags (@) {
|
||||
my @tags = @_;
|
||||
check_state 'testing_test_case';
|
||||
|
||||
%{STATE->{all_tags}} = map { $_ => 1 } @tags;
|
||||
}
|
||||
|
||||
=head2 no_more_scenarios
|
||||
|
||||
no_more_scenarios;
|
||||
|
||||
Ends a declaration of a test. Similar to C<done_testing> in L<Test::More>.
|
||||
|
||||
=cut
|
||||
|
||||
sub no_more_scenarios () {
|
||||
check_state 'testing_test_case';
|
||||
my $spec = pop_state;
|
||||
|
||||
# Do not clutter AST with data the compiler does not need
|
||||
delete $spec->{zone_name_template};
|
||||
delete $spec->{all_tags};
|
||||
|
||||
TestUtil::DSL::Compiler::compile($spec)->();
|
||||
}
|
||||
|
||||
=head2 scenario
|
||||
|
||||
Declares one or more scenario blocks.
|
||||
|
||||
A scenario is defined by a name and a set of expectations. The name is used to
|
||||
derive the name of a zone on which to run the test case being tested. The
|
||||
result of this run is a collection of messages, which are then compared to the
|
||||
expected result declared in the scenario block.
|
||||
|
||||
The scenario block body is a special coderef, evaluated in a special context which
|
||||
gives meaning to a set of scenario-specific keywords. See L<SCENARIO-SPECIFIC
|
||||
KEYWORDS> for more information on what keywords are valid in a scenario block.
|
||||
|
||||
The C<scenario> keywords has several legal syntaxes.
|
||||
|
||||
The first form declares a single scenario:
|
||||
|
||||
scenario 'SCENARIO-NAME' => sub {
|
||||
# scenario declaration here
|
||||
};
|
||||
|
||||
The second form declares multiple scenarios, all sharing the same expectations:
|
||||
|
||||
scenario qw(SCENARIO-ONE SCENARIO-TWO) => sub {
|
||||
# scenario declaration here
|
||||
};
|
||||
|
||||
Scenario names may end with a number range expressed as C<{M..N}> where C<M>
|
||||
and C<N> are integers. This is a shorthand for listing scenarios that all
|
||||
share the same prefix but differ only by a numbered suffix. This notation
|
||||
allows for concise declarations of scenarios that may be configured
|
||||
differently but are expected to yield the same set of messages from the test
|
||||
case. For example, the following two declarations are equivalent:
|
||||
|
||||
scenario qw(GOOD-{1..2} EXAMPLE-{1..4}) => sub { ... };
|
||||
|
||||
scenario qw(GOOD-1 GOOD-2
|
||||
EXAMPLE-1 EXAMPLE-2 EXAMPLE-3 EXAMPLE-4) => sub { ... };
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
sub scenario (@) {
|
||||
check_state 'testing_test_case';
|
||||
|
||||
croak "At least two arguments required" unless scalar @_ >= 2;
|
||||
croak "A 'root_hints' must appear before a 'scenario' block"
|
||||
unless exists STATE->{root_hints};
|
||||
|
||||
my $definition = pop @_;
|
||||
my @names = _expand_scenario_names(@_);
|
||||
|
||||
my @context = caller(0);
|
||||
|
||||
my $scenario = {
|
||||
names => \@names,
|
||||
caller => [ @context[1..2] ],
|
||||
body => do {
|
||||
my $PARENT_STATE = STATE;
|
||||
push_state 'scenario';
|
||||
|
||||
STATE->{status} = [ 'testable' ];
|
||||
|
||||
# Keep track of contents of “all_tags” so that expect and forbid
|
||||
# can raise errors if given a tag not in that list.
|
||||
STATE->{all_tags} = $PARENT_STATE->{all_tags};
|
||||
|
||||
# Keep track of keys never mentioned by “expect” or “forbid” respectively
|
||||
# so that “expect_others” and “forbid_others” can be defined in terms
|
||||
# of “expect” and “forbid” respectively.
|
||||
%{STATE->{not_expected}} = map { $_ => 1 } keys %{STATE->{all_tags}};
|
||||
%{STATE->{not_forbidden}} = map { $_ => 1 } keys %{STATE->{all_tags}};
|
||||
|
||||
# Evaluate definition
|
||||
my $obj = do { $definition->(); pop_state; };
|
||||
|
||||
# Clean up
|
||||
delete $obj->{all_tags};
|
||||
delete $obj->{not_expected};
|
||||
delete $obj->{not_forbidden};
|
||||
|
||||
# Set default zone name (template)
|
||||
$obj->{zone} //= STATE->{zone_name_template};
|
||||
|
||||
# Sanity checks
|
||||
if (not defined $obj->{zone}) {
|
||||
croak "No 'zone' keyword in scenario block and no previous "
|
||||
. "'zone_name_template' seen";
|
||||
}
|
||||
|
||||
# TODO do we need more sanity checks?
|
||||
$obj;
|
||||
}
|
||||
};
|
||||
|
||||
foreach my $name (@{$scenario->{names}}) {
|
||||
STATE->{scenario_status}{$name} = $scenario->{body}{status};
|
||||
}
|
||||
push @{STATE->{ops}}, [ scenario => $scenario ];
|
||||
}
|
||||
|
||||
|
||||
=head2 testing_test_case
|
||||
|
||||
testing_test_case 'MyModule' 'mymodule01';
|
||||
|
||||
Declare a unit test for a test case. The arguments for that keyword are the
|
||||
name of the test plan, and the name of the test case being tested
|
||||
respectively.
|
||||
|
||||
The DSL expects this keyword to be used first, before any other keyword.
|
||||
|
||||
=cut
|
||||
|
||||
sub testing_test_case ($$) {
|
||||
check_state undef;
|
||||
push_state 'testing_test_case';
|
||||
|
||||
my ($test_module, $test_case) = @_;
|
||||
|
||||
STATE->{test_module} = $test_module;
|
||||
STATE->{test_case} = $test_case;
|
||||
}
|
||||
|
||||
|
||||
=head2 root_hints
|
||||
|
||||
root_hints 'ns1.example' => [ qw(198.51.113.10 2001:db8:0:8::53) ],
|
||||
'ns2.example' => [ qw(198.51.113.20 2001:db8:0:8::1:53) ];
|
||||
|
||||
Declare the set of name servers which are authoritative for the root zone.
|
||||
These root hints apply to all scenarios that follow this keyword.
|
||||
|
||||
This keyword must be used at least one before defining the first scenario
|
||||
block.
|
||||
|
||||
=cut
|
||||
|
||||
sub root_hints (%) {
|
||||
my (%root_hints) = @_;
|
||||
check_state 'testing_test_case';
|
||||
STATE->{root_hints} = 1;
|
||||
|
||||
push @{STATE->{ops}}, [ root_hints => \%root_hints ];
|
||||
}
|
||||
|
||||
=head2 zone_name_template
|
||||
|
||||
zone_name_template '{SCENARIO}.{TESTCASE}.xa';
|
||||
zone_name_template 'child.parent.{SCENARIO}.{TESTCASE}.xa';
|
||||
|
||||
Declare a default zone name template for the C<scenario> specifications that follow.
|
||||
|
||||
The string passed as arguments may contain placeholders, such as C<{SCENARIO}>
|
||||
or C<{TESTCASE}>, that are substituted accordingly.
|
||||
|
||||
=cut
|
||||
|
||||
sub zone_name_template ($) {
|
||||
my ($template) = @_;
|
||||
check_state 'testing_test_case';
|
||||
STATE->{zone_name_template} = $template;
|
||||
}
|
||||
|
||||
=head2 clear_cache
|
||||
|
||||
clear_cache;
|
||||
|
||||
Clears the resolver cache for subsequent tests. This might be necessary if
|
||||
this caching somehow causes negative side effects.
|
||||
|
||||
Note that it is unnecessary to use this keyword right after L<root_hints>,
|
||||
because L<root_hints> also clears the resolver cache.
|
||||
|
||||
=cut
|
||||
|
||||
sub clear_cache () {
|
||||
check_state 'testing_test_case';
|
||||
push @{STATE->{ops}}, [ "clear_cache" ];
|
||||
}
|
||||
|
||||
|
||||
=head1 SCENARIO-SPECIFIC KEYWORDS
|
||||
|
||||
=head2 zone
|
||||
|
||||
zone 'myzone.example.xa';
|
||||
zone 'myzone.{SCENARIO}.{TESTCASE}.xb';
|
||||
|
||||
Declare a zone name to be used in the scenario.
|
||||
|
||||
This declaration is optional, because the default value is inherited from the
|
||||
top-level keyword L<zone_name_template>. It can be useful for one or two
|
||||
exceptions to a general rule.
|
||||
|
||||
The same placeholders that are valid for L<zone_name_template> can also be
|
||||
used here.
|
||||
|
||||
=cut
|
||||
|
||||
sub zone ($) {
|
||||
my ($zone) = @_;
|
||||
check_state 'scenario';
|
||||
|
||||
# Template expansion is done at a later stage
|
||||
STATE->{zone} = $zone;
|
||||
}
|
||||
|
||||
=head2 fake_ds
|
||||
|
||||
fake_ds <key tag>, <algo>, <type>, <digest>
|
||||
fake_ds 51966, 8, 3, 'ABCDABCDABCDABCD';
|
||||
|
||||
Provide a DS record as part of the fake delegation to be used in the scenario.
|
||||
|
||||
=cut
|
||||
|
||||
sub fake_ds($$$$) {
|
||||
my ($tag, $algo, $type, $digest) = @_;
|
||||
|
||||
unless ( _is_uint_bits($tag, 16) ) {
|
||||
croak "$tag: not a valid key tag";
|
||||
}
|
||||
unless ( _is_uint_bits($algo, 8) ) {
|
||||
croak "$algo: not a valid algorithm";
|
||||
}
|
||||
unless ( _is_uint_bits($type, 8) ) {
|
||||
croak "$type: not a valid type";
|
||||
}
|
||||
unless ( $digest =~ /^ (?: [0-9a-f]{2} )+ $/ix ) {
|
||||
croak "$digest: not a valid digest";
|
||||
}
|
||||
|
||||
push @{STATE->{fake_ds}}, {
|
||||
keytag => $tag,
|
||||
algorithm => $algo,
|
||||
type => $type,
|
||||
digest => $digest
|
||||
};
|
||||
}
|
||||
|
||||
=head2 fake_ns
|
||||
|
||||
fake_ns <nameserver>[, <IP address…>]
|
||||
|
||||
Provide an NS record as part of the fake delegation to be used in the scenario.
|
||||
The keyword accepts a name server name and optionally a list of IP addresses that
|
||||
will be used as glue records if given.
|
||||
|
||||
Examples:
|
||||
|
||||
fake_ns 'ns1.example';
|
||||
fake_ns 'ns1.example' => '192.0.2.50';
|
||||
fake_ns 'ns1.example' => '192.0.2.50', '2001:db8:0:8::53';
|
||||
|
||||
Passing the same name server name to more than one C<fake_ns> keyword is not
|
||||
allowed and is an error.
|
||||
|
||||
=cut
|
||||
|
||||
sub fake_ns($@) {
|
||||
my ($name, @ips) = @_;
|
||||
|
||||
if (exists STATE->{fake_ns}{$name}) {
|
||||
croak "'fake_ns' cannot be used for '$name' more than once";
|
||||
}
|
||||
|
||||
STATE->{fake_ns}{$name} = \@ips;
|
||||
}
|
||||
|
||||
=head2 expect
|
||||
|
||||
List one or more tags that the test case is expected to generate when it is run
|
||||
on the scenario being defined.
|
||||
|
||||
This keyword allows for multiple syntaxes.
|
||||
|
||||
The first form specifies that at least one message of a certain tag is to be
|
||||
expected among the test case’s output for the scenario:
|
||||
|
||||
expect <tag>;
|
||||
|
||||
The second form is a shorthand that avoids repeating the C<expect> keyword. It
|
||||
is equivalent to using the first form as many times as there are tags given as
|
||||
arguments.
|
||||
|
||||
expect <tag1>, <tag2>, ...;
|
||||
|
||||
The third form specifies a single tag name and a hashref of keys and criteria.
|
||||
It specifies that a message whose tag matches the name and whose arguments
|
||||
exist and match the supplied criteria must exist among the test case’s output.
|
||||
See L<Criteria> below for a more in-depth explanation of this form.
|
||||
|
||||
expect <tag> => { <argument1> => <criterion1>, ... };
|
||||
|
||||
The fourth form takes a tag name and a coderef: it searches for all messages
|
||||
whose tag matches, evaluates the coderef with C<@_> set to the list of
|
||||
messages matching the tag and expects the coderef to return a true value. This
|
||||
form is useful for situations where the third form falls short. See L<Criteria>
|
||||
below for examples.
|
||||
|
||||
expect <tag> => sub { my @messages = @_; ... };
|
||||
|
||||
The C<expect> keyword can be used more than once in a scenario. All of the
|
||||
checks specified by C<expect> and C<forbid> keywords must pass in order for
|
||||
the scenario to pass.
|
||||
|
||||
=head3 Criteria
|
||||
|
||||
For the third form, arguments can be matched against:
|
||||
|
||||
=over
|
||||
|
||||
=item strings, which are compared with C<eq>;
|
||||
|
||||
=item regular expressions;
|
||||
|
||||
=item and coderefs, where C<$_> is bound to the message parameter’s value.
|
||||
|
||||
=back
|
||||
|
||||
The following expects C<SOME_TAG> to be generated with arguments C<ns_list>,
|
||||
C<other_argument>, C<third_argument> and C<fourth_argument>. C<ns_list> must
|
||||
be equal to C<ns1.example/127.0.60.1>, C<other_argument> must match
|
||||
C</^ns2\..*/>, C<third_argument> must be case-insensitively equal to
|
||||
C<example> and C<fourth_argument> is only tested for presence.
|
||||
|
||||
expect SOME_TAG => {
|
||||
ns_list => 'ns1.example/127.0.60.1',
|
||||
other_argument => qr/^ns2\..*/,
|
||||
third_argument => sub { fc $_ eq fc 'EXAMPLE' },
|
||||
fourth_argument => sub { 1 },
|
||||
};
|
||||
|
||||
Note that if the test case emits C<SOME_TAG> with an argument that is not
|
||||
listed in the C<expect> keyword, it is deemed an error.
|
||||
|
||||
Checking that a message tag has no parameters at all can also be done as
|
||||
follows:
|
||||
|
||||
expect TAG_WITHOUT_PARAMETERS => {};
|
||||
|
||||
More free-form criteria can be provided by means of the fourth form. The following
|
||||
example checks if the scenario generated exactly three times a given message tag:
|
||||
|
||||
expect SOME_TAG => sub { scalar @_ == 3 };
|
||||
|
||||
The following example ensures that all instances of SOME_TAG have a
|
||||
C<some_argument> parameter equal to the string C<ns1.example/127.0.60.1>:
|
||||
|
||||
expect SOME_TAG => sub {
|
||||
my @messages = @_;
|
||||
for my $m (@messages) {
|
||||
return 0 if $m->{some_argument} ne 'ns1.example/127.0.60.1';
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
=cut
|
||||
|
||||
sub expect (@) {
|
||||
if (scalar @_ == 2 and ref $_[1] eq 'HASH') {
|
||||
# Third form
|
||||
my ($tag, $args) = @_;
|
||||
_declare_message_test( expect => $tag, args => $args );
|
||||
}
|
||||
elsif (scalar @_ == 2 and ref $_[1] eq 'CODE') {
|
||||
# Fourth form
|
||||
my ($tag, $code) = @_;
|
||||
_declare_message_test( expect => $tag, code => $code );
|
||||
}
|
||||
elsif (scalar @_ >= 1) {
|
||||
# First or second form
|
||||
foreach my $tag (@_) {
|
||||
_declare_message_test( expect => $tag );
|
||||
}
|
||||
}
|
||||
else {
|
||||
croak "Need at least one argument";
|
||||
}
|
||||
}
|
||||
|
||||
=head2 forbid
|
||||
|
||||
forbid <tag1>, <tag2>, …
|
||||
|
||||
Specifies that the listed tags are not to be emitted by the test case in the
|
||||
scenario being defined. In other words, in the messages generated by the test
|
||||
case, no message should appear whose tags are in the listed tags.
|
||||
|
||||
The C<forbid> keyword can be used more than once in a scenario. All of the
|
||||
checks specified by C<expect> and C<forbid> keywords must pass in order for
|
||||
the scenario to pass.
|
||||
|
||||
=cut
|
||||
|
||||
sub forbid (@) {
|
||||
my @tags = @_;
|
||||
|
||||
croak "Need at least one argument" unless scalar @tags >= 1;
|
||||
|
||||
foreach my $tag (@_) {
|
||||
_declare_message_test( forbid => $tag );
|
||||
}
|
||||
}
|
||||
|
||||
sub _declare_message_test {
|
||||
my ( $type, $tag, %args ) = @_;
|
||||
my @context = caller(1);
|
||||
|
||||
exists STATE->{all_tags}{$tag}
|
||||
or croak "Tag '$tag' used in '$type' clause but not declared in 'all_tags'";
|
||||
|
||||
delete STATE->{not_expected}{$tag} if $type eq 'expect';
|
||||
delete STATE->{not_forbidden}{$tag} if $type eq 'forbid';
|
||||
|
||||
push @{STATE->{message_tests}}, [ $type, [ @context[1..2] ], $tag, %args ];
|
||||
}
|
||||
|
||||
=head2 expect_others
|
||||
|
||||
expect_others;
|
||||
|
||||
Specifies that all tags not listed by any C<forbid> tag in the scenario
|
||||
definition must appear in the test case’s output for the scenario.
|
||||
|
||||
=cut
|
||||
|
||||
sub expect_others () {
|
||||
croak "Cannot use expect_others if forbid_others is already given" if STATE->{forbid_others};
|
||||
croak "Cannot use expect_others more than once" if STATE->{expect_others};
|
||||
STATE->{expect_others} = 1;
|
||||
|
||||
_declare_message_test( expect => $_ ) foreach ( keys %{STATE->{not_forbidden}} );
|
||||
}
|
||||
|
||||
=head2 forbid_others
|
||||
|
||||
forbid_others;
|
||||
|
||||
Specifies that all tags not listed by any C<expect> tag in the scenario
|
||||
definition must not appear in the test case’s output for the scenario.
|
||||
|
||||
=cut
|
||||
|
||||
sub forbid_others () {
|
||||
croak "Cannot use forbid_others if expect_others is already given" if STATE->{expect_others};
|
||||
croak "Cannot use forbid_others more than once" if STATE->{forbid_others};
|
||||
STATE->{forbid_others} = 1;
|
||||
|
||||
_declare_message_test( forbid => $_ ) foreach ( keys %{STATE->{not_expected}} );
|
||||
}
|
||||
|
||||
=head2 not_testable
|
||||
|
||||
not_testable 'optional reason';
|
||||
|
||||
Mark the scenario as not testable.
|
||||
|
||||
Scenarios marked as not testable are skipped during testing, unless they are
|
||||
listed explicitly in the C<ZONEMASTER_SELECTED_SUBTESTS> environment variable.
|
||||
|
||||
It is semantically equivalent to L<Test::More#todo_skip>.
|
||||
|
||||
This facility is useful for defining scenarios which cannot be tested because
|
||||
the infrastructure (e.g. DNS servers, test zones…) needed to elicit the set of
|
||||
messages expected by the scenario is not yet available.
|
||||
|
||||
No packets related to the scenario are saved to the test’s C<.data> file when
|
||||
C<ZONEMASTER_RECORD> is set in the environment. This means that no data is
|
||||
recorded for a test zone that does not reflect the scenario accurately.
|
||||
Rerecording is only necessary when the C<not_testable> keyword is removed.
|
||||
|
||||
The C<not_testable> keyword should not be used for other reasons than lack of
|
||||
infrastructure, such as if the test fails because of a known bug in the test
|
||||
case’s implementation. In those situations, C<todo> is more appropriate.
|
||||
|
||||
The optional reason, if supplied, is used in the test harness’s diagnostic
|
||||
output. It is useful for documenting the exact reason why the test is not
|
||||
testable, for example by referring to an item on an issue tracker.
|
||||
|
||||
=cut
|
||||
|
||||
sub not_testable (;$) {
|
||||
if (exists STATE->{todo}) {
|
||||
croak "'not_testable' cannot be combined with 'todo'";
|
||||
}
|
||||
if (exists STATE->{not_testable}) {
|
||||
croak "'not_testable' can only be given once";
|
||||
}
|
||||
STATE->{status} = [ 'not_testable', $_[0] ];
|
||||
}
|
||||
|
||||
=head2 todo
|
||||
|
||||
todo 'optional reason';
|
||||
|
||||
Mark the scenario as “to do”.
|
||||
|
||||
Scenarios marked as to do are executed normally during testing, but are
|
||||
expected to fail. Failing “to do” scenarios do not cause the parent test suite
|
||||
to fail.
|
||||
|
||||
It is semantically equivalent to L<Test::More#TODO:-BLOCK>.
|
||||
|
||||
This facility is useful for defining scenarios that are expected to fail
|
||||
because of a known bug in the test case’s implementation that has not been
|
||||
fixed yet.
|
||||
|
||||
Packets related to the scenario are saved to the test’s C<.data> file when
|
||||
C<ZONEMASTER_RECORD> is set in the environment. This means that no rerecord is
|
||||
necessary when the C<todo> keyword is removed or when trying to fix the
|
||||
implementation.
|
||||
|
||||
The optional reason, if supplied, is used in the test harness’s diagnostic
|
||||
output. It is useful for documenting the exact reason why the test is expected
|
||||
to fail, for example by referring to an item on an issue tracker.
|
||||
|
||||
=cut
|
||||
|
||||
sub todo (;$) {
|
||||
if (exists STATE->{not_testable}) {
|
||||
croak "'todo' cannot be combined with 'not_testable'";
|
||||
}
|
||||
if (exists STATE->{todo}) {
|
||||
croak "'todo' can only be given once";
|
||||
}
|
||||
STATE->{status} = [ 'todo', $_[0] ];
|
||||
}
|
||||
|
||||
1;
|
||||
494
zonemaster-engine/t/TestUtil/DSL/Compiler.pm
Normal file
494
zonemaster-engine/t/TestUtil/DSL/Compiler.pm
Normal file
@@ -0,0 +1,494 @@
|
||||
package TestUtil::DSL::Compiler;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use v5.24;
|
||||
|
||||
use Carp qw(croak confess);
|
||||
use Test::More ();
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
TestUtil::DSL::Compiler - compiler for the language defined in TestUtil::DSL
|
||||
|
||||
=cut
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=head2 compile
|
||||
|
||||
Compiles the AST, obtained as a result of parsing an instance of the DSL, into
|
||||
a coderef that executes the tests defined in that DSL.
|
||||
|
||||
Set C<$TestUtil::DSL::Compiler::DEBUG> to a non-zero value in order to obtain
|
||||
debugging output. If running the corresponding C<.t> file in a harness, you
|
||||
may need to enable verbose output in order to see it (e.g. by passing C<-v>
|
||||
to C<prove>).
|
||||
|
||||
=cut
|
||||
|
||||
our $DEBUG = 0;
|
||||
|
||||
|
||||
sub compile {
|
||||
my ($ast) = @_;
|
||||
|
||||
confess unless exists $ast->{test_module};
|
||||
confess unless exists $ast->{test_case};
|
||||
|
||||
my $test_module = $ast->{test_module};
|
||||
my $test_case = $ast->{test_case};
|
||||
|
||||
my $test_method = sub {
|
||||
my ( $zone_name ) = @_;
|
||||
return Zonemaster::Engine->test_method(
|
||||
$test_module, $test_case, Zonemaster::Engine->zone( $zone_name ));
|
||||
};
|
||||
|
||||
my $func_preamble = _compile_preamble($ast);
|
||||
my $func_select_subtests = _compile_select_subtests($ast);
|
||||
my @compiled_ops = _compile_ops($ast->{ops}, $test_case, $test_method);
|
||||
|
||||
my $datafile = 't/' . File::Basename::basename( $0, '.t' ) . '.data';
|
||||
|
||||
return sub {
|
||||
my $context = {};
|
||||
|
||||
if ($DEBUG) {
|
||||
Test::More::note("Dumping AST read after parsing DSL:");
|
||||
Test::More::note(Test::More::explain($ast));
|
||||
}
|
||||
|
||||
$func_preamble->();
|
||||
|
||||
$context->{todo_tests} = [];
|
||||
$context->{disabled_tests} = [];
|
||||
$context->{selected_subtests} = $func_select_subtests->(
|
||||
$ENV{ZONEMASTER_SELECTED_SCENARIOS},
|
||||
$ENV{ZONEMASTER_DISABLED_SCENARIOS});
|
||||
|
||||
if ( not $ENV{ZONEMASTER_RECORD} ) {
|
||||
Test::More::note "Loading data file: $datafile";
|
||||
die q{Stored data file missing} if not -r $datafile;
|
||||
Zonemaster::Engine::Nameserver->restore( $datafile );
|
||||
Test::More::note "Done loading data file.";
|
||||
Zonemaster::Engine::Profile->effective->set( q{no_network} => 1 );
|
||||
}
|
||||
|
||||
Zonemaster::Engine::Profile->effective->merge(
|
||||
Zonemaster::Engine::Profile->from_json( qq({ "test_cases": ["$test_case"] }) ));
|
||||
|
||||
foreach my $callback ( @compiled_ops ) {
|
||||
$callback->($context);
|
||||
}
|
||||
|
||||
Test::More::done_testing();
|
||||
|
||||
if (scalar @{$context->{todo_tests}}) {
|
||||
Test::More::diag("The following scenarios are marked as TODO:\n");
|
||||
Test::More::diag(" $_") foreach @{$context->{todo_tests}};
|
||||
}
|
||||
if (scalar @{$context->{disabled_tests}}) {
|
||||
Test::More::diag("The following scenarios were not run:\n");
|
||||
Test::More::diag(" $_") foreach @{$context->{disabled_tests}};
|
||||
}
|
||||
|
||||
if ( $ENV{ZONEMASTER_RECORD} ) {
|
||||
Test::More::note "Saving data file: $datafile";
|
||||
Zonemaster::Engine::Nameserver->save( $datafile );
|
||||
Test::More::note "Done saving data file.";
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
# Top-level compilation helper functions
|
||||
|
||||
sub _compile_preamble {
|
||||
my ($ast) = @_;
|
||||
|
||||
confess unless exists $ast->{test_module};
|
||||
|
||||
my $testmod = q{Zonemaster::Engine::Test::} . $ast->{test_module};
|
||||
|
||||
return sub {
|
||||
Test::More::use_ok( q{Zonemaster::Engine::Nameserver} );
|
||||
Test::More::use_ok( $testmod );
|
||||
};
|
||||
}
|
||||
|
||||
sub _compile_root_hints {
|
||||
my ( $root_hints ) = @_;
|
||||
|
||||
return sub {
|
||||
Zonemaster::Engine::Recursor->remove_fake_addresses( '.' );
|
||||
Zonemaster::Engine::Recursor->add_fake_addresses( '.', $root_hints );
|
||||
Zonemaster::Engine::Recursor::clear_cache();
|
||||
}
|
||||
}
|
||||
|
||||
sub _compile_clear_cache {
|
||||
return sub {
|
||||
Zonemaster::Engine::Recursor::clear_cache();
|
||||
}
|
||||
}
|
||||
|
||||
sub _compile_select_subtests {
|
||||
my ($ast) = @_;
|
||||
|
||||
return sub {
|
||||
my ( $selected_scenarios, $disabled_scenarios ) = @_;
|
||||
|
||||
# Make a copy so as not to clobber the AST
|
||||
my %scenario_status = ( %{$ast->{scenario_status}} );
|
||||
|
||||
# Force the listed tests in $selected_scenarios to run as if their
|
||||
# status was testable.
|
||||
if ( defined $selected_scenarios ) {
|
||||
%scenario_status = map {
|
||||
$_ => [ 'skip', 'not selected by environment variable' ]
|
||||
} ( keys %scenario_status );
|
||||
foreach my $name ( split(/, */, $selected_scenarios) ) {
|
||||
croak "$name: no such scenario" unless exists $scenario_status{$name};
|
||||
$scenario_status{$name} = [ 'testable' ];
|
||||
}
|
||||
}
|
||||
|
||||
# Skip the tests explicitly listed in $disabled_scenarios
|
||||
foreach my $to_disable ( split(/, */, $disabled_scenarios // "") ) {
|
||||
croak "$to_disable: no such scenario" unless exists $scenario_status{$to_disable};
|
||||
$scenario_status{$to_disable} =
|
||||
[ 'skip', 'disabled by environment variable' ];
|
||||
}
|
||||
|
||||
return \%scenario_status;
|
||||
};
|
||||
}
|
||||
|
||||
sub _compile_ops {
|
||||
my ( $ops, $test_case, $test_method ) = @_;
|
||||
|
||||
return map {
|
||||
my ( $type, @args ) = @$_;
|
||||
if ( $type eq 'root_hints' ) {
|
||||
_compile_root_hints( @args );
|
||||
}
|
||||
elsif ( $type eq 'scenario' ) {
|
||||
_compile_run_scenario_block( @args, $test_case, $test_method );
|
||||
}
|
||||
elsif ( $type eq 'clear_cache' ) {
|
||||
_compile_clear_cache();
|
||||
}
|
||||
} @$ops;
|
||||
}
|
||||
|
||||
sub _compile_run_scenario_block {
|
||||
my ( $scenario_block, $test_case, $test_method ) = @_;
|
||||
|
||||
# Compiling a scenario block is a bit tricky because determining which
|
||||
# scenarios to run is done at runtime. We can’t just compile the scenario
|
||||
# block to a sub directly and be done with it; we need to wrap it into a
|
||||
# bit of code that checks if the scenario was forcibly enabled or disabled
|
||||
# in the environment before making the decision to run it or not.
|
||||
my $compiled_scenarios = _compile_scenario_block( $scenario_block, $test_case, $test_method );
|
||||
|
||||
my ($file, $line) = @{$compiled_scenarios->{caller}};
|
||||
my $callback = $compiled_scenarios->{callback};
|
||||
|
||||
return sub {
|
||||
my ( $context ) = @_;
|
||||
|
||||
my $selected_subtests = $context->{selected_subtests};
|
||||
my $disabled_tests = $context->{disabled_tests};
|
||||
my $todo_tests = $context->{todo_tests};
|
||||
|
||||
foreach my $descriptor (@{$compiled_scenarios->{args}}) {
|
||||
my $name = $descriptor->{scenario_name};
|
||||
my $zone_name = $descriptor->{zone_name};
|
||||
|
||||
my ( $status, $reason ) = @{$selected_subtests->{$name}};
|
||||
my $name_and_reason = "$name" . (defined $reason ? " ($reason)" : "");
|
||||
|
||||
if ( $status eq 'skip' ) {
|
||||
Test::More->builder->skip( $name_and_reason );
|
||||
push @$disabled_tests, $name_and_reason;
|
||||
next;
|
||||
}
|
||||
elsif ( $status eq 'not_testable' ) {
|
||||
Test::More->builder->todo_skip( $name_and_reason );
|
||||
push @$disabled_tests, $name_and_reason;
|
||||
next;
|
||||
}
|
||||
elsif ( $status eq 'todo' ) {
|
||||
# Avoid passing undef to Test::Builder::todo_start(), otherwise
|
||||
# older versions (e.g. the one shipped with Perl 5.26) will not
|
||||
# enable the todo status properly for the subtest if no reason
|
||||
# was provided for the todo keyword in the DSL.
|
||||
Test::More->builder->todo_start( $reason // "" );
|
||||
push @$todo_tests, $name_and_reason;
|
||||
}
|
||||
|
||||
my $ret = Test::More::subtest($name, $callback, $zone_name);
|
||||
# Test::More->builder->no_diag(1) was called inside the callback just before
|
||||
# exiting in order to suppress the default diag() output in case of failure
|
||||
# of the subtest. Be sure to re-enable it before continuing.
|
||||
Test::More->builder->no_diag(0);
|
||||
|
||||
if ( $status eq 'todo' ) {
|
||||
Test::More->builder->todo_end();
|
||||
}
|
||||
elsif ( $status eq 'testable' and not $ret ) {
|
||||
Test::More::diag(<<DIAG);
|
||||
Failed scenario '$name'
|
||||
at $file line $line.
|
||||
DIAG
|
||||
}
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
sub _compile_scenario_block {
|
||||
my ( $scenario_block, $test_case, $test_method ) = @_;
|
||||
|
||||
my @subtest_args = ();
|
||||
foreach my $name (@{$scenario_block->{names}}) {
|
||||
my $zone = lc _expand_template(
|
||||
$scenario_block->{body}{zone},
|
||||
SCENARIO => $name, TESTCASE => $test_case );
|
||||
|
||||
push @subtest_args, { scenario_name => $name, zone_name => $zone };
|
||||
}
|
||||
|
||||
return {
|
||||
caller => $scenario_block->{caller},
|
||||
callback => _compile_scenario_subtest( $scenario_block, $test_method ),
|
||||
args => \@subtest_args
|
||||
};
|
||||
}
|
||||
|
||||
# Scenario compilation helper functions
|
||||
|
||||
sub _compile_scenario_subtest {
|
||||
my ( $scenario_declaration, $test_method ) = @_;
|
||||
|
||||
my $func_add_fake_delegation = _compile_fake_ns( $scenario_declaration );
|
||||
my $func_add_fake_ds = _compile_fake_ds( $scenario_declaration );
|
||||
my @func_message_tests = _compile_message_tests( $scenario_declaration );
|
||||
|
||||
return sub {
|
||||
my ( $zone_name ) = @_;
|
||||
Test::More::plan(tests => scalar @func_message_tests + 1);
|
||||
|
||||
Test::More::note("Zone: $zone_name");
|
||||
$func_add_fake_delegation->($zone_name) if defined $func_add_fake_delegation;
|
||||
$func_add_fake_ds->($zone_name) if defined $func_add_fake_ds;
|
||||
|
||||
my @messages = $test_method->( $zone_name );
|
||||
|
||||
if ( my ( $error ) = grep { $_->tag eq 'MODULE_ERROR' } @messages ) {
|
||||
Test::More::fail("Test case executes without errors");
|
||||
Test::More::diag("Module died with the following error:\n " . $error->args->{"msg"});
|
||||
}
|
||||
else {
|
||||
Test::More::pass("Test case executes without errors");
|
||||
$_->( @messages ) foreach ( @func_message_tests );
|
||||
}
|
||||
|
||||
# At the end of a subtest, if there is at least one failure,
|
||||
# Test::More automatically generates a comment containing the location
|
||||
# of the failing test. This location is wrong, so we squelch any
|
||||
# diag() output. There is no other way than to call no_diag() here.
|
||||
Test::More->builder->no_diag(1);
|
||||
};
|
||||
}
|
||||
|
||||
sub _compile_fake_ns {
|
||||
my ( $scenario_declaration ) = @_;
|
||||
|
||||
if ( exists $scenario_declaration->{body}{fake_ns} ) {
|
||||
my $undel_ns = $scenario_declaration->{body}{fake_ns};
|
||||
return sub {
|
||||
my ( $zone_name ) = @_;
|
||||
# Use default value of "fill_in_empty_oob_glue".
|
||||
Zonemaster::Engine->add_fake_delegation(
|
||||
$zone_name => $undel_ns, fill_in_empty_oob_glue => 1 );
|
||||
}
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub _compile_fake_ds {
|
||||
my ( $scenario_declaration ) = @_;
|
||||
|
||||
if ( exists $scenario_declaration->{body}{fake_ds} ) {
|
||||
my @undel_ds = @{$scenario_declaration->{body}{fake_ds}};
|
||||
return sub {
|
||||
my ( $zone_name ) = @_;
|
||||
Zonemaster::Engine->add_fake_ds( $zone_name => $_ ) foreach @undel_ds;
|
||||
}
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub _compile_message_tests {
|
||||
my ( $scenario_declaration ) = @_;
|
||||
|
||||
map {
|
||||
my ( $type, $caller, $tag, %args ) = @$_;
|
||||
|
||||
if ( $type eq 'expect' and exists $args{code} ) {
|
||||
_compile_expect_with_code( $caller, $tag, $args{code} );
|
||||
}
|
||||
elsif ( $type eq 'expect' and exists $args{args} ) {
|
||||
_compile_expect_with_args( $caller, $tag, %{$args{args}} );
|
||||
}
|
||||
elsif ( $type eq 'expect' ) {
|
||||
_compile_expect_bare( $caller, $tag );
|
||||
}
|
||||
elsif ( $type eq 'forbid' ) {
|
||||
_compile_forbid( $caller, $tag );
|
||||
}
|
||||
} ( @{$scenario_declaration->{body}{message_tests}} );
|
||||
}
|
||||
|
||||
sub _compile_expect_bare {
|
||||
my ( $caller, $tag ) = @_;
|
||||
|
||||
return sub {
|
||||
_ok(
|
||||
scalar ( grep { $_->{tag} eq $tag } @_ ),
|
||||
"Tag '$tag' is outputted",
|
||||
$caller )
|
||||
or Test::More::diag("Tag '$tag' should have been outputted, but wasn't");
|
||||
};
|
||||
}
|
||||
|
||||
sub _compile_expect_with_args {
|
||||
my ( $caller, $tag, %args ) = @_;
|
||||
|
||||
my %predicates;
|
||||
my $explanation = "Looked for a message whose tag is '$tag'";
|
||||
my $where = "where";
|
||||
|
||||
foreach my $argument ( sort keys %args ) {
|
||||
$explanation .= "\n $where '$argument' ";
|
||||
$where = " and";
|
||||
|
||||
my $value = $args{$argument};
|
||||
my $comparison = do {
|
||||
if ( ref $value eq '' ) {
|
||||
$explanation .= "equals '$value'";
|
||||
sub { $_[0] eq $_[1] };
|
||||
}
|
||||
elsif ( ref $value eq 'Regexp' ) {
|
||||
$explanation .= "matches $value";
|
||||
sub { $_[0] =~ $_[1] };
|
||||
}
|
||||
elsif ( ref $value eq 'CODE' ) {
|
||||
$explanation .= "satisfies a custom predicate";
|
||||
sub { $_[1]->($_[0]) };
|
||||
}
|
||||
else {
|
||||
croak "Invalid argument value given to key '$argument'";
|
||||
}
|
||||
};
|
||||
$predicates{$argument} = sub {
|
||||
$comparison->($_->{args}{$argument}, $value)
|
||||
};
|
||||
}
|
||||
|
||||
$explanation .= "\n and contains no argument other than those listed above";
|
||||
|
||||
my $combined_predicate = sub {
|
||||
foreach my $k ( keys %{$_->{args}} ) {
|
||||
if ( exists $predicates{$k} ) {
|
||||
return 0 unless $predicates{$k}->($_);
|
||||
}
|
||||
else {
|
||||
# The message contains an argument that isn’t matched by anything
|
||||
# from the 'expect' keyword, so we fail the test for this message.
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
};
|
||||
|
||||
return sub {
|
||||
my @messages = grep { $_->{tag} eq $tag } @_;
|
||||
_ok(
|
||||
scalar ( grep { $combined_predicate->($_) } @messages ),
|
||||
"Messages of tag '$tag' exist with specified arguments",
|
||||
$caller )
|
||||
or do {
|
||||
Test::More::diag($explanation);
|
||||
Test::More::diag("Here are all messages that unsuccessfully matched:");
|
||||
Test::More::diag(" $_->{tag} " . $_->argstr) foreach ( @messages );
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
sub _compile_expect_with_code {
|
||||
my ( $caller, $tag, $code ) = @_;
|
||||
|
||||
return sub {
|
||||
my @messages_of_tag = grep { $_->{tag} eq $tag } @_;
|
||||
_ok(
|
||||
$code->( @messages_of_tag ),
|
||||
"Messages of tag '$tag' satisfy custom callback",
|
||||
$caller );
|
||||
};
|
||||
}
|
||||
|
||||
sub _compile_forbid {
|
||||
my ( $caller, $tag ) = @_;
|
||||
|
||||
return sub {
|
||||
_ok(
|
||||
! scalar ( grep { $_->{tag} eq $tag } @_ ),
|
||||
"Tag '$tag' is not outputted",
|
||||
$caller )
|
||||
or Test::More::diag("Tag '$tag' shouldn't have been outputted, but it was");
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
# Miscellaneous utilities
|
||||
|
||||
sub _expand_template {
|
||||
my ($template, %variables) = @_;
|
||||
|
||||
confess unless defined $template;
|
||||
|
||||
my $result = $template;
|
||||
for my $k (keys %variables) {
|
||||
$result =~ s/\{$k\}/$variables{$k}/g;
|
||||
}
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
# A version of Test::More::ok that prints the correct location when a test fails.
|
||||
|
||||
sub _ok {
|
||||
my ( $ok, $test_name, $caller ) = @_;
|
||||
my ( $file, $line ) = @$caller;
|
||||
|
||||
# This is the only way to squelch the automatic diagnostics that are printed
|
||||
# on the TAP output when ok() fails. The TAP output erroneously points to
|
||||
# a line in t/TestUtil/DSL/Compiler.pm when an error occurs.
|
||||
Test::More->builder->no_diag(1);
|
||||
my $ret = Test::More::ok( $ok, $test_name );
|
||||
Test::More->builder->no_diag(0);
|
||||
|
||||
unless ( $ok ) {
|
||||
Test::More::diag(<<DIAG);
|
||||
Failed test '$test_name'
|
||||
at $file line $line.
|
||||
DIAG
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user