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:
973
zonemaster-cli/lib/Zonemaster/CLI.pm
Normal file
973
zonemaster-cli/lib/Zonemaster/CLI.pm
Normal file
@@ -0,0 +1,973 @@
|
||||
# Brief help module to define the exception we use for early exits.
|
||||
package Zonemaster::Engine::Exception::NormalExit;
|
||||
use v5.26;
|
||||
use warnings;
|
||||
use parent 'Zonemaster::Engine::Exception';
|
||||
|
||||
# The actual interesting module.
|
||||
package Zonemaster::CLI;
|
||||
|
||||
use v5.26;
|
||||
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare( "v8.0.1" );
|
||||
|
||||
use Locale::TextDomain 'Zonemaster-CLI';
|
||||
|
||||
use Encode;
|
||||
use File::Slurp;
|
||||
use Getopt::Long qw[GetOptionsFromArray :config gnu_compat bundling no_auto_abbrev];
|
||||
use JSON::XS;
|
||||
use List::Util qw[max uniq];
|
||||
use Net::IP::XS;
|
||||
use Pod::Usage;
|
||||
use POSIX qw[setlocale LC_MESSAGES LC_CTYPE];
|
||||
use Readonly;
|
||||
use Scalar::Util qw[blessed];
|
||||
use Time::HiRes;
|
||||
use Try::Tiny;
|
||||
use Zonemaster::CLI::TestCaseSet;
|
||||
use Zonemaster::Engine::Exception;
|
||||
use Zonemaster::Engine::Logger::Entry;
|
||||
use Zonemaster::Engine::Normalization qw[normalize_name];
|
||||
use Zonemaster::Engine::Translator;
|
||||
use Zonemaster::Engine::Util qw[parse_hints];
|
||||
use Zonemaster::Engine::Validation qw[validate_ipv4 validate_ipv6];
|
||||
use Zonemaster::Engine;
|
||||
use Zonemaster::LDNS;
|
||||
|
||||
our %numeric = Zonemaster::Engine::Logger::Entry->levels;
|
||||
our $JSON = JSON::XS->new->allow_blessed->convert_blessed->canonical;
|
||||
our $SCRIPT = $0;
|
||||
|
||||
Readonly our $EXIT_SUCCESS => 0;
|
||||
Readonly our $EXIT_GENERIC_ERROR => 1;
|
||||
Readonly our $EXIT_USAGE_ERROR => 2;
|
||||
|
||||
Readonly our $DS_RE => qr/^(?:[[:digit:]]+,){3}[[:xdigit:]]+$/;
|
||||
|
||||
STDOUT->autoflush( 1 );
|
||||
|
||||
sub my_pod2usage {
|
||||
my ( %opts ) = @_;
|
||||
|
||||
pod2usage(
|
||||
-input => $SCRIPT,
|
||||
-output => $opts{output},
|
||||
-verbose => $opts{verbosity},
|
||||
-exitcode => 'NOEXIT',
|
||||
);
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
# Returns an integer representing an OS exit status.
|
||||
sub run {
|
||||
my ( $class, @argv ) = @_;
|
||||
|
||||
my $opt_count = 0;
|
||||
my @opt_ds = ();
|
||||
my $opt_dump_profile = 0;
|
||||
my $opt_elapsed = 0;
|
||||
my $opt_encoding = undef;
|
||||
my $opt_help = 0;
|
||||
my $opt_hints;
|
||||
my $opt_ipv4 = undef;
|
||||
my $opt_ipv6 = undef;
|
||||
my $opt_json = undef;
|
||||
my $opt_json_stream = 0;
|
||||
my $opt_json_translate = undef;
|
||||
my $opt_level = 'NOTICE';
|
||||
my $opt_list_tests = 0;
|
||||
my $opt_locale = undef;
|
||||
my @opt_ns = ();
|
||||
my $opt_nstimes = 0;
|
||||
my $opt_profile;
|
||||
my $opt_progress = undef;
|
||||
my $opt_raw;
|
||||
my $opt_restore;
|
||||
my $opt_save;
|
||||
my $opt_show_level = 1;
|
||||
my $opt_show_module = 0;
|
||||
my $opt_show_testcase = 0;
|
||||
my $opt_sourceaddr4;
|
||||
my $opt_sourceaddr6;
|
||||
my $opt_stop_level = '';
|
||||
my @opt_test = ();
|
||||
my $opt_time = 1;
|
||||
my $opt_version = 0;
|
||||
|
||||
{
|
||||
local $SIG{__WARN__} = sub { print STDERR $_[0] };
|
||||
|
||||
GetOptionsFromArray(
|
||||
\@argv,
|
||||
'count!' => \$opt_count,
|
||||
'ds=s' => \@opt_ds,
|
||||
'dump-profile!' => \$opt_dump_profile,
|
||||
'dump_profile!' => \$opt_dump_profile,
|
||||
'elapsed!' => \$opt_elapsed,
|
||||
'encoding=s' => \$opt_encoding,
|
||||
'hints=s' => \$opt_hints,
|
||||
'help|h|usage|?!' => \$opt_help,
|
||||
'ipv4!' => \$opt_ipv4,
|
||||
'ipv6!' => \$opt_ipv6,
|
||||
'json!' => \$opt_json,
|
||||
'json-stream!' => \$opt_json_stream,
|
||||
'json_stream!' => \$opt_json_stream,
|
||||
'json-translate!' => \$opt_json_translate,
|
||||
'json_translate!' => \$opt_json_translate,
|
||||
'level=s' => \$opt_level,
|
||||
'list-tests!' => \$opt_list_tests,
|
||||
'list_tests!' => \$opt_list_tests,
|
||||
'locale=s' => \$opt_locale,
|
||||
'ns=s' => \@opt_ns,
|
||||
'nstimes!' => \$opt_nstimes,
|
||||
'profile=s' => \$opt_profile,
|
||||
'progress!' => \$opt_progress,
|
||||
'raw!' => \$opt_raw,
|
||||
'restore=s' => \$opt_restore,
|
||||
'save=s' => \$opt_save,
|
||||
'show-level!' => \$opt_show_level,
|
||||
'show_level!' => \$opt_show_level,
|
||||
'show-module!' => \$opt_show_module,
|
||||
'show_module!' => \$opt_show_module,
|
||||
'show-testcase!' => \$opt_show_testcase,
|
||||
'show_testcase!' => \$opt_show_testcase,
|
||||
'sourceaddr4=s' => \$opt_sourceaddr4,
|
||||
'sourceaddr6=s' => \$opt_sourceaddr6,
|
||||
'stop-level=s' => \$opt_stop_level,
|
||||
'stop_level=s' => \$opt_stop_level,
|
||||
'test=s' => \@opt_test,
|
||||
'time!' => \$opt_time,
|
||||
'version!' => \$opt_version,
|
||||
)
|
||||
or do {
|
||||
my_pod2usage( verbosity => 0, output => \*STDERR );
|
||||
return 2;
|
||||
};
|
||||
}
|
||||
|
||||
if ( $opt_help ) {
|
||||
my_pod2usage( verbosity => 1, output => \*STDOUT );
|
||||
say "Severity levels from highest to lowest:";
|
||||
say " CRITICAL, ERROR, WARNING, NOTICE, INFO, DEBUG, DEBUG2, DEBUG3";
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
$opt_level = uc $opt_level;
|
||||
$opt_stop_level = uc $opt_stop_level;
|
||||
|
||||
my @accumulator;
|
||||
my %counter;
|
||||
my $printed_something;
|
||||
|
||||
if ( $opt_locale ) {
|
||||
undef $ENV{LANGUAGE};
|
||||
$ENV{LC_ALL} = $opt_locale;
|
||||
}
|
||||
|
||||
# Set LC_MESSAGES and LC_CTYPE separately
|
||||
# (https://www.gnu.org/software/gettext/manual/html_node/Triggering.html#Triggering)
|
||||
if ( not defined setlocale( LC_MESSAGES, "" ) ) {
|
||||
my $locale = ( $ENV{LANGUAGE} || $ENV{LC_ALL} || $ENV{LC_MESSAGES} );
|
||||
say STDERR __x(
|
||||
"Warning: setting locale category LC_MESSAGES to {locale} failed -- is it installed on this system?",
|
||||
locale => $locale ) . "\n\n";
|
||||
}
|
||||
|
||||
if ( not defined setlocale( LC_CTYPE, "" ) ) {
|
||||
my $locale = ( $ENV{LC_ALL} || $ENV{LC_CTYPE} );
|
||||
say STDERR __x(
|
||||
"Warning: setting locale category LC_CTYPE to {locale} failed -- is it installed on this system?",
|
||||
locale => $locale ) . "\n\n";
|
||||
}
|
||||
|
||||
if ( $opt_version ) {
|
||||
print_versions();
|
||||
return $EXIT_SUCCESS;
|
||||
}
|
||||
|
||||
if ( $opt_list_tests ) {
|
||||
print_test_list();
|
||||
return $EXIT_SUCCESS;
|
||||
}
|
||||
|
||||
# errors and warnings
|
||||
if ( defined $opt_encoding ) {
|
||||
say STDERR __( "Warning: deprecated --encoding, simply remove it from your usage." );
|
||||
}
|
||||
|
||||
if ( $opt_json_stream and defined $opt_json and not $opt_json ) {
|
||||
say STDERR __( "Error: --json-stream and --no-json cannot be used together." );
|
||||
return $EXIT_USAGE_ERROR;
|
||||
}
|
||||
|
||||
if ( defined $opt_json_translate ) {
|
||||
unless ( $opt_json or $opt_json_stream ) {
|
||||
printf STDERR __( "Warning: --json-translate has no effect without either --json or --json-stream." )
|
||||
. "\n";
|
||||
}
|
||||
if ( $opt_json_translate ) {
|
||||
printf STDERR __( "Warning: deprecated --json-translate, use --no-raw instead." ) . "\n";
|
||||
}
|
||||
else {
|
||||
printf STDERR __( "Warning: deprecated --no-json-translate, use --raw instead." ) . "\n";
|
||||
}
|
||||
}
|
||||
|
||||
# align values
|
||||
$opt_json = 1 if $opt_json_stream;
|
||||
$opt_raw //= defined $opt_json_translate ? !$opt_json_translate : 0;
|
||||
|
||||
# Filehandle for diagnostics output
|
||||
my $fh_diag = ( $opt_json or $opt_raw or $opt_dump_profile )
|
||||
? *STDERR # Structured output mode (e.g. JSON)
|
||||
: *STDOUT; # Human readable output mode
|
||||
|
||||
my $show_progress = $opt_progress // !!-t STDOUT && !$opt_json && !$opt_raw;
|
||||
|
||||
if ( $opt_profile ) {
|
||||
say $fh_diag __x( "Loading profile from {path}.", path => $opt_profile );
|
||||
my $json = read_file( $opt_profile );
|
||||
my $foo = Zonemaster::Engine::Profile->from_json( $json );
|
||||
my $profile = Zonemaster::Engine::Profile->default;
|
||||
$profile->merge( $foo );
|
||||
Zonemaster::Engine::Profile->effective->merge( $profile );
|
||||
}
|
||||
|
||||
if ( defined $opt_sourceaddr4 ) {
|
||||
local $@;
|
||||
eval {
|
||||
Zonemaster::Engine::Profile->effective->set( q{resolver.source4}, $opt_sourceaddr4 );
|
||||
1;
|
||||
} or do {
|
||||
say STDERR __x( "Error: invalid value for --sourceaddr4: {reason}", reason => $@ );
|
||||
return $EXIT_USAGE_ERROR;
|
||||
};
|
||||
}
|
||||
|
||||
if ( defined $opt_sourceaddr6 ) {
|
||||
local $@;
|
||||
eval {
|
||||
Zonemaster::Engine::Profile->effective->set( q{resolver.source6}, $opt_sourceaddr6 );
|
||||
1;
|
||||
} or do {
|
||||
say STDERR __x( "Error: invalid value for --sourceaddr6: {reason}", reason => $@ );
|
||||
return $EXIT_USAGE_ERROR;
|
||||
};
|
||||
}
|
||||
|
||||
{
|
||||
my %all_methods = Zonemaster::Engine->all_methods;
|
||||
my $cases = Zonemaster::CLI::TestCaseSet->new( #
|
||||
Zonemaster::Engine::Profile->effective->get( q{test_cases} ),
|
||||
\%all_methods,
|
||||
);
|
||||
|
||||
for my $test ( @opt_test ) {
|
||||
my @modifiers = Zonemaster::CLI::TestCaseSet->parse_modifier_expr( $test );
|
||||
while ( @modifiers ) {
|
||||
my $op = shift @modifiers;
|
||||
my $term = shift @modifiers;
|
||||
|
||||
if ( !$cases->apply_modifier( $op, $term ) ) {
|
||||
say STDERR __x( "Error: unrecognized term '{term}' in --test.", term => $term ) . "\n";
|
||||
return $EXIT_USAGE_ERROR;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
Zonemaster::Engine::Profile->effective->set( q{test_cases}, [ $cases->to_list ] ),
|
||||
}
|
||||
|
||||
# These two must come after any profile from command line has been loaded
|
||||
# to make any IPv4/IPv6 option override the profile setting.
|
||||
if ( defined( $opt_ipv4 ) ) {
|
||||
Zonemaster::Engine::Profile->effective->set( q{net.ipv4}, $opt_ipv4 );
|
||||
}
|
||||
if ( defined( $opt_ipv6 ) ) {
|
||||
Zonemaster::Engine::Profile->effective->set( q{net.ipv6}, $opt_ipv6 );
|
||||
}
|
||||
|
||||
if ( $opt_dump_profile ) {
|
||||
do_dump_profile();
|
||||
return $EXIT_SUCCESS;
|
||||
}
|
||||
|
||||
if ( $opt_stop_level and not defined( $numeric{$opt_stop_level} ) ) {
|
||||
say STDERR __x( "Failed to recognize stop level '{level}'.", level => $opt_stop_level );
|
||||
return $EXIT_USAGE_ERROR;
|
||||
}
|
||||
|
||||
if ( not defined $numeric{$opt_level} ) {
|
||||
say STDERR __( "--level must be one of CRITICAL, ERROR, WARNING, NOTICE, INFO, DEBUG, DEBUG2 or DEBUG3." );
|
||||
return $EXIT_USAGE_ERROR;
|
||||
}
|
||||
|
||||
if ( $opt_restore ) {
|
||||
Zonemaster::Engine->preload_cache( $opt_restore );
|
||||
}
|
||||
|
||||
my $level_width = 0;
|
||||
foreach ( keys %numeric ) {
|
||||
if ( $numeric{$opt_level} <= $numeric{$_} ) {
|
||||
my $width_l10n = length( decode_utf8( translate_severity( $_ ) ) );
|
||||
$level_width = $width_l10n if $width_l10n > $level_width;
|
||||
}
|
||||
}
|
||||
|
||||
my $translator;
|
||||
my %field_width = (
|
||||
seconds => 7,
|
||||
level => $level_width,
|
||||
module => 12,
|
||||
testcase => 14
|
||||
);
|
||||
my %header_names = ();
|
||||
my %remaining_space = ();
|
||||
|
||||
# Callback defined here so it closes over the setup above.
|
||||
# But we can’t use it right now because the translator isn’t initialized.
|
||||
my $message_printer = sub {
|
||||
my ( $entry ) = @_;
|
||||
|
||||
print_spinner() if $show_progress;
|
||||
|
||||
my $entry_level = $entry->level;
|
||||
|
||||
$counter{ uc $entry_level } += 1;
|
||||
|
||||
if ( $numeric{ uc $entry_level } >= $numeric{$opt_level} ) {
|
||||
$printed_something = 1;
|
||||
|
||||
if ( $opt_json and $opt_json_stream ) {
|
||||
my %r;
|
||||
|
||||
$r{timestamp} = $entry->timestamp if $opt_time;
|
||||
$r{module} = $entry->module if $opt_show_module;
|
||||
$r{testcase} = $entry->testcase if $opt_show_testcase;
|
||||
$r{tag} = $entry->tag;
|
||||
$r{level} = $entry_level if $opt_show_level;
|
||||
$r{args} = $entry->args if $entry->args;
|
||||
$r{message} = $translator->translate_tag( $entry ) unless $opt_raw;
|
||||
|
||||
say $JSON->encode( \%r );
|
||||
}
|
||||
elsif ( $opt_json and not $opt_json_stream ) {
|
||||
# Don't do anything
|
||||
}
|
||||
else {
|
||||
my $prefix = q{};
|
||||
if ( $opt_time ) {
|
||||
$prefix .= sprintf "%*.2f ", ${ field_width { seconds } }, $entry->timestamp;
|
||||
}
|
||||
|
||||
if ( $opt_show_level ) {
|
||||
$prefix .= $opt_raw ? $entry->level : translate_severity( $entry->level );
|
||||
my $space_l10n =
|
||||
${ field_width { level } } - length( decode_utf8( translate_severity( $entry_level ) ) ) + 1;
|
||||
$prefix .= ' ' x $space_l10n;
|
||||
}
|
||||
|
||||
if ( $opt_show_module ) {
|
||||
$prefix .= sprintf "%-*s ", ${ field_width { module } }, $entry->module;
|
||||
}
|
||||
|
||||
if ( $opt_show_testcase ) {
|
||||
$prefix .= sprintf "%-*s ", ${ field_width { testcase } }, $entry->testcase;
|
||||
}
|
||||
|
||||
if ( $opt_raw ) {
|
||||
$prefix .= $entry->tag;
|
||||
|
||||
my $message = $entry->argstr;
|
||||
my @lines = split /\n/, $message;
|
||||
|
||||
printf "%s%s %s\n", $prefix, ' ', @lines ? shift @lines : '';
|
||||
for my $line ( @lines ) {
|
||||
printf "%s%s %s\n", $prefix, '>', $line;
|
||||
}
|
||||
}
|
||||
else {
|
||||
if ( $entry_level eq q{DEBUG3}
|
||||
and scalar( keys %{ $entry->args } ) == 1
|
||||
and defined $entry->args->{packet} )
|
||||
{
|
||||
my $packet = $entry->args->{packet};
|
||||
my $padding = q{ } x length $prefix;
|
||||
$entry->args->{packet} = q{};
|
||||
printf "%s%s\n", $prefix, $translator->translate_tag( $entry );
|
||||
foreach my $line ( split /\n/, $packet ) {
|
||||
printf "%s%s\n", $padding, $line;
|
||||
}
|
||||
}
|
||||
else {
|
||||
printf "%s%s\n", $prefix, $translator->translate_tag( $entry );
|
||||
}
|
||||
}
|
||||
} ## end else [ if ( $opt_json and $opt_json_stream)]
|
||||
} ## end if ( $numeric{ uc $entry_level...})
|
||||
if ( $opt_stop_level and $numeric{ uc $entry->level } >= $numeric{$opt_stop_level} ) {
|
||||
die(
|
||||
Zonemaster::Engine::Exception::NormalExit->new(
|
||||
{ message => "Saw message at level " . $entry->level }
|
||||
)
|
||||
);
|
||||
}
|
||||
};
|
||||
|
||||
# Instead, hold early messages in a temporary queue and switch to the
|
||||
# actual callback when we are ready.
|
||||
my @held_messages;
|
||||
Zonemaster::Engine->logger->callback(
|
||||
sub {
|
||||
my ( $entry ) = @_;
|
||||
push @held_messages, @_;
|
||||
}
|
||||
);
|
||||
|
||||
if ( @argv > 1 ) {
|
||||
say STDERR __(
|
||||
"Only one domain can be given for testing. Did you forget to prepend an option with '--<OPTION>'?" );
|
||||
return $EXIT_USAGE_ERROR;
|
||||
}
|
||||
elsif ( @argv < 1 ) {
|
||||
say STDERR __( "Must give the name of a domain to test." );
|
||||
return $EXIT_USAGE_ERROR;
|
||||
}
|
||||
|
||||
my ( $domain ) = @argv;
|
||||
|
||||
( my $errors, $domain ) = normalize_name( decode( 'utf8', $domain ) );
|
||||
|
||||
if ( @opt_ns ) {
|
||||
local $@;
|
||||
eval {
|
||||
check_fake_delegation( $domain, @opt_ns );
|
||||
1;
|
||||
} or do {
|
||||
print STDERR $@;
|
||||
return $EXIT_USAGE_ERROR;
|
||||
};
|
||||
}
|
||||
|
||||
if ( @opt_ds ) {
|
||||
check_fake_ds( @opt_ds );
|
||||
}
|
||||
|
||||
if ( scalar @$errors > 0 ) {
|
||||
my $error_message;
|
||||
foreach my $err ( @$errors ) {
|
||||
$error_message .= $err->string . "\n";
|
||||
}
|
||||
print STDERR $error_message;
|
||||
return $EXIT_USAGE_ERROR;
|
||||
}
|
||||
|
||||
if ( defined $opt_hints ) {
|
||||
my $hints_data;
|
||||
my $error = undef;
|
||||
try {
|
||||
my $hints_text = read_file( $opt_hints ) // die "read_file failed\n";
|
||||
local $SIG{__WARN__} = \¨
|
||||
$hints_data = parse_hints( $hints_text )
|
||||
}
|
||||
catch {
|
||||
$error = $_;
|
||||
};
|
||||
|
||||
if ( defined $error ) {
|
||||
print STDERR __x( "Error loading hints file: {message}", message => $error );
|
||||
return $EXIT_USAGE_ERROR;
|
||||
}
|
||||
|
||||
Zonemaster::Engine::Recursor->remove_fake_addresses( '.' );
|
||||
Zonemaster::Engine::Recursor->add_fake_addresses( '.', $hints_data );
|
||||
} ## end if ( defined $opt_hints)
|
||||
|
||||
# This can generate early log messages.
|
||||
if ( @opt_ns ) {
|
||||
local $@;
|
||||
eval {
|
||||
add_fake_delegation( $domain, @opt_ns );
|
||||
1;
|
||||
} or do {
|
||||
print STDERR $@;
|
||||
return $EXIT_USAGE_ERROR;
|
||||
};
|
||||
}
|
||||
|
||||
if ( @opt_ds ) {
|
||||
add_fake_ds( $domain, @opt_ds );
|
||||
}
|
||||
|
||||
if ( not $opt_raw ) {
|
||||
$translator = Zonemaster::Engine::Translator->new;
|
||||
$translator->locale( $opt_locale )
|
||||
if $opt_locale;
|
||||
|
||||
%header_names = (
|
||||
seconds => __( 'Seconds' ),
|
||||
level => __( 'Level' ),
|
||||
module => __( 'Module' ),
|
||||
testcase => __( 'Testcase' ),
|
||||
message => __( 'Message' )
|
||||
);
|
||||
foreach ( keys %header_names ) {
|
||||
$field_width{$_} = _max( $field_width{$_}, length( decode_utf8( $header_names{$_} ) ) );
|
||||
$remaining_space{$_} = $field_width{$_} - length( decode_utf8( $header_names{$_} ) );
|
||||
}
|
||||
}
|
||||
|
||||
if ( $opt_profile or @opt_test ) {
|
||||
# Separate initialization from main output in human readable output mode
|
||||
print "\n" if $fh_diag eq *STDOUT;
|
||||
}
|
||||
|
||||
if ( not $opt_raw and not $opt_json ) {
|
||||
my $header = q{};
|
||||
|
||||
if ( $opt_time ) {
|
||||
$header .= sprintf "%s%s ", $header_names{seconds}, " " x $remaining_space{seconds};
|
||||
}
|
||||
if ( $opt_show_level ) {
|
||||
$header .= sprintf "%s%s ", $header_names{level}, " " x $remaining_space{level};
|
||||
}
|
||||
if ( $opt_show_module ) {
|
||||
$header .= sprintf "%s%s ", $header_names{module}, " " x $remaining_space{module};
|
||||
}
|
||||
if ( $opt_show_testcase ) {
|
||||
$header .= sprintf "%s%s ", $header_names{testcase}, " " x $remaining_space{testcase};
|
||||
}
|
||||
$header .= sprintf "%s\n", $header_names{message};
|
||||
|
||||
if ( $opt_time ) {
|
||||
$header .= sprintf "%s ", "=" x $field_width{seconds};
|
||||
}
|
||||
if ( $opt_show_level ) {
|
||||
$header .= sprintf "%s ", "=" x $field_width{level};
|
||||
}
|
||||
if ( $opt_show_module ) {
|
||||
$header .= sprintf "%s ", "=" x $field_width{module};
|
||||
}
|
||||
if ( $opt_show_testcase ) {
|
||||
$header .= sprintf "%s ", "=" x $field_width{testcase};
|
||||
}
|
||||
$header .= sprintf "%s\n", "=" x $field_width{message};
|
||||
|
||||
print $header;
|
||||
} ## end if ( not $opt_raw and ...)
|
||||
|
||||
# Now we are ready to actually print messages, including those that are
|
||||
# currently in the hold queue.
|
||||
while ( my $entry = pop @held_messages ) {
|
||||
$message_printer->( $entry );
|
||||
}
|
||||
Zonemaster::Engine->logger->callback( $message_printer );
|
||||
|
||||
# Actually run tests!
|
||||
eval { Zonemaster::Engine->test_zone( $domain ); };
|
||||
|
||||
if ( $@ ) {
|
||||
my $err = $@;
|
||||
if ( blessed $err and $err->isa( "Zonemaster::Engine::Exception::NormalExit" ) ) {
|
||||
say STDERR "Exited early: " . $err->message;
|
||||
}
|
||||
else {
|
||||
die $err; # Don't know what it is, rethrow
|
||||
}
|
||||
}
|
||||
|
||||
if ( not $opt_raw and not $opt_json ) {
|
||||
if ( not $printed_something ) {
|
||||
say __( "Looks OK." );
|
||||
}
|
||||
}
|
||||
|
||||
my $json_output = {};
|
||||
|
||||
if ( $opt_count ) {
|
||||
my %entries;
|
||||
foreach my $e ( @{ Zonemaster::Engine->logger->entries } ) {
|
||||
$entries{$e->level}{$e->tag} += 1;
|
||||
}
|
||||
|
||||
if ( $opt_json ) {
|
||||
$json_output->{count} = {};
|
||||
foreach my $level ( sort { $numeric{$b} <=> $numeric{$a} } keys %counter ) {
|
||||
$json_output->{count}{by_level}{$level} = $counter{$level};
|
||||
}
|
||||
|
||||
foreach my $level ( sort { $numeric{$b} <=> $numeric{$a} } keys %entries ) {
|
||||
foreach my $tag ( sort keys %{ $entries{$level} } ) {
|
||||
$json_output->{count}{by_message_tag}{$level}{$tag} = $entries{$level}{$tag};
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $header1 = __( 'Level' );
|
||||
my $max1 = length $header1;
|
||||
my $header2 = __( 'Number of log entries' );
|
||||
my $max2 = length $header2;
|
||||
|
||||
foreach my $level ( sort { $numeric{$b} <=> $numeric{$a} } keys %counter ) {
|
||||
my $len = length translate_severity( $level );
|
||||
$max1 = $len if $len > $max1;
|
||||
}
|
||||
|
||||
printf "\n\n%${max1}s\t%${max2}s", $header1, $header2;
|
||||
printf "\n%s\t%s\n", '=' x $max1, '=' x $max2;
|
||||
|
||||
foreach my $level ( sort { $numeric{$b} <=> $numeric{$a} } keys %counter ) {
|
||||
printf "%${max1}s\t%${max2}d\n", translate_severity( $level ), $counter{$level};
|
||||
}
|
||||
|
||||
my $header3 = __( 'Message tag' );
|
||||
my $max3 = max map { length "$_" } ( ( map { keys %{ $_ } } ( values %entries ) ), $header3 );
|
||||
my $header4 = __( 'Count' );
|
||||
my $max4 = max map { length "$_" } ( ( map { values %{ $_ } } ( values %entries ) ), $header4 );
|
||||
|
||||
printf "\n%${max1}s\t%${max3}s\t%${max4}s", $header1, $header3, $header4;
|
||||
printf "\n%${max1}s\t%${max3}s\t%${max4}s\n", '=' x $max1, '=' x $max3, '=' x $max4;
|
||||
foreach my $level ( sort { $numeric{$b} <=> $numeric{$a} } keys %entries ) {
|
||||
foreach my $tag ( sort keys %{ $entries{$level} } ) {
|
||||
printf "%${max1}s\t%${max3}s\t%${max4}s\n", $level, $tag, $entries{$level}{$tag};
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ( $opt_nstimes ) {
|
||||
my $zone = Zonemaster::Engine->zone( $domain );
|
||||
my %all_nss = %{ Zonemaster::Engine::Nameserver::object_cache };
|
||||
my @child_nss = @{ $zone->ns };
|
||||
my @parent_nss = @{ $zone->parent->ns };
|
||||
my @all_responded_nss;
|
||||
|
||||
foreach my $ns_name ( keys %all_nss ) {
|
||||
foreach my $ns ( values %{ $all_nss{$ns_name} } ) {
|
||||
push @all_responded_nss, $ns if scalar @{ $ns->times } > 0;
|
||||
}
|
||||
}
|
||||
|
||||
my %nss_filter = map { $_ => undef } ( @child_nss, @parent_nss );
|
||||
my @other_nss = grep { ! exists $nss_filter{$_} } @all_responded_nss;
|
||||
|
||||
if ( $opt_json ) {
|
||||
my @times;
|
||||
|
||||
my sub json_nstimes {
|
||||
my ( $ns ) = @_;
|
||||
return {
|
||||
'ns' => $ns->string,
|
||||
'max' => 1000 * $ns->max_time,
|
||||
'min' => 1000 * $ns->min_time,
|
||||
'avg' => 1000 * $ns->average_time,
|
||||
'stddev' => 1000 * $ns->stddev_time,
|
||||
'median' => 1000 * $ns->median_time,
|
||||
'total' => 1000 * $ns->sum_time,
|
||||
'count' => scalar @{ $ns->times }
|
||||
};
|
||||
}
|
||||
|
||||
my %section_mapping = (
|
||||
'child' => \@child_nss,
|
||||
'parent' => \@parent_nss,
|
||||
'other' => \@other_nss
|
||||
);
|
||||
|
||||
foreach my $section_name ( sort keys %section_mapping ) {
|
||||
my @entries = map { json_nstimes( $_ ) } sort @{ $section_mapping{$section_name} };
|
||||
push @times, { $section_name => \@entries };
|
||||
}
|
||||
|
||||
$json_output->{nstimes} = \@times;
|
||||
}
|
||||
else {
|
||||
my $header = __( 'Name servers' );
|
||||
my $max = max map { length( "$_" ) } ( ( @child_nss, @parent_nss, @all_responded_nss ), $header );
|
||||
printf "\n%${max}s %s\n", $header, ' Max Min Avg Stddev Median Total Count';
|
||||
printf "%${max}s %s\n", '=' x $max, ' ========== ========== ========== ========== ========== =========== ===========';
|
||||
|
||||
my $total_queries_count = 0;
|
||||
my $total_queries_times = 0;
|
||||
my %nss_already_processed;
|
||||
|
||||
my sub print_nstimes {
|
||||
my ( $ns, $max, $total_queries_count, $total_queries_times, $nss_already_processed_ref ) = @_;
|
||||
my %nss_already_processed = %{ $nss_already_processed_ref };
|
||||
|
||||
printf "%${max}s ", $ns->string;
|
||||
printf "%11.2f ", 1000 * $ns->max_time;
|
||||
printf "%10.2f ", 1000 * $ns->min_time;
|
||||
printf "%10.2f ", 1000 * $ns->average_time;
|
||||
printf "%10.2f ", 1000 * $ns->stddev_time;
|
||||
printf "%10.2f ", 1000 * $ns->median_time;
|
||||
printf "%11.2f ", 1000 * $ns->sum_time;
|
||||
printf "%11d\n", scalar @{ $ns->times };
|
||||
$total_queries_count += scalar @{ $ns->times } unless $nss_already_processed{$ns};
|
||||
$total_queries_times += ( 1000 * $ns->sum_time ) unless $nss_already_processed{$ns};
|
||||
|
||||
return $total_queries_count, $total_queries_times;
|
||||
}
|
||||
|
||||
my %section_mapping = (
|
||||
1 => { __( 'Child zone' ) => \@child_nss },
|
||||
2 => { __( 'Parent zone' ) => \@parent_nss },
|
||||
3 => { __( 'Other' ) => \@other_nss }
|
||||
);
|
||||
|
||||
foreach my $section_order ( sort keys %section_mapping ) {
|
||||
foreach my $section_header ( keys % { $section_mapping{$section_order} } ) {
|
||||
printf "%s %s\n", $section_header, '-' x ( ( $max - length $section_header ) - 1 );
|
||||
|
||||
foreach my $section_nss ( sort @{ $section_mapping{$section_order}{$section_header} } ) {
|
||||
( $total_queries_count, $total_queries_times ) =
|
||||
print_nstimes( $section_nss, $max, $total_queries_count, $total_queries_times, \%nss_already_processed );
|
||||
$nss_already_processed{$section_nss} = 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
printf "%${max}s %s\n", '=' x $max, ' ========== ========== ========== ========== ========== =========== ===========';
|
||||
printf "%${max}s %67.2f %11s\n", __( 'Grand total' ), $total_queries_times, $total_queries_count;
|
||||
}
|
||||
} ## end if ( $opt_nstimes )
|
||||
|
||||
if ( $opt_elapsed ) {
|
||||
my $last = Zonemaster::Engine->logger->entries->[-1];
|
||||
|
||||
if ( $opt_json ) {
|
||||
$json_output->{elapsed} = $last->timestamp;
|
||||
}
|
||||
else {
|
||||
printf "\nTotal test run time: %0.1f seconds.\n", $last->timestamp;
|
||||
}
|
||||
}
|
||||
|
||||
if ( $opt_json and not $opt_json_stream ) {
|
||||
my $res = Zonemaster::Engine->logger->json( $opt_level );
|
||||
$res = $JSON->decode( $res );
|
||||
foreach ( @$res ) {
|
||||
unless ( $opt_raw ) {
|
||||
my %e = %$_;
|
||||
my $entry = Zonemaster::Engine::Logger::Entry->new( \%e );
|
||||
$_->{message} = $translator->translate_tag( $entry );
|
||||
}
|
||||
delete $_->{timestamp} unless $opt_time;
|
||||
delete $_->{level} unless $opt_show_level;
|
||||
delete $_->{module} unless $opt_show_module;
|
||||
delete $_->{testcase} unless $opt_show_testcase;
|
||||
}
|
||||
$json_output->{results} = $res;
|
||||
}
|
||||
|
||||
if ( scalar keys %$json_output ) {
|
||||
say $JSON->encode( $json_output );
|
||||
}
|
||||
|
||||
if ( $opt_save ) {
|
||||
Zonemaster::Engine->save_cache( $opt_save );
|
||||
}
|
||||
|
||||
return $EXIT_SUCCESS;
|
||||
} ## end sub run
|
||||
|
||||
sub check_fake_delegation {
|
||||
my ( $domain, @ns ) = @_;
|
||||
|
||||
foreach my $pair ( @ns ) {
|
||||
my ( $name, $ip ) = split( '/', $pair, 2 );
|
||||
|
||||
if ( $pair =~ tr/\/// > 1 or not $name ) {
|
||||
die __( "--ns must be a name or a name/ip pair." ) . "\n";
|
||||
}
|
||||
|
||||
( my $errors, $name ) = normalize_name( decode( 'utf8', $name ) );
|
||||
|
||||
if ( scalar @$errors > 0 ) {
|
||||
my $error_message = "Invalid name in --ns argument:\n";
|
||||
foreach my $err ( @$errors ) {
|
||||
$error_message .= "\t" . $err->string . "\n";
|
||||
}
|
||||
die $error_message;
|
||||
}
|
||||
|
||||
if ( $ip ) {
|
||||
my $net_ip = Net::IP::XS->new( $ip );
|
||||
unless ( validate_ipv4( $ip ) or validate_ipv6( $ip ) ) {
|
||||
die Net::IP::XS::Error()
|
||||
? "Invalid IP address in --ns argument:\n\t" . Net::IP::XS::Error() . "\n"
|
||||
: "Invalid IP address in --ns argument.\n";
|
||||
}
|
||||
}
|
||||
} ## end foreach my $pair ( @ns )
|
||||
|
||||
return;
|
||||
} ## end sub check_fake_delegation
|
||||
|
||||
sub check_fake_ds {
|
||||
my ( @ds ) = @_;
|
||||
|
||||
foreach my $str ( @ds ) {
|
||||
unless ( $str =~ /$DS_RE/ ) {
|
||||
say STDERR __(
|
||||
"--ds ds data must be in the form \"keytag,algorithm,type,digest\". E.g. space is not permitted anywhere in the string."
|
||||
);
|
||||
exit( 1 );
|
||||
}
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub add_fake_delegation {
|
||||
my ( $domain, @ns ) = @_;
|
||||
my @ns_with_no_ip;
|
||||
my %data;
|
||||
|
||||
foreach my $pair ( @ns ) {
|
||||
my ( $name, $ip ) = split( '/', $pair, 2 );
|
||||
|
||||
( my $errors, $name ) = normalize_name( decode( 'utf8', $name ) );
|
||||
|
||||
if ( $ip ) {
|
||||
push @{ $data{$name} }, $ip;
|
||||
}
|
||||
else {
|
||||
push @ns_with_no_ip, $name;
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $ns ( @ns_with_no_ip ) {
|
||||
if ( not exists $data{$ns} ) {
|
||||
$data{$ns} = undef;
|
||||
}
|
||||
}
|
||||
|
||||
return Zonemaster::Engine->add_fake_delegation( $domain => \%data );
|
||||
|
||||
} ## end sub add_fake_delegation
|
||||
|
||||
sub add_fake_ds {
|
||||
my ( $domain, @ds ) = @_;
|
||||
my @data;
|
||||
|
||||
foreach my $str ( @ds ) {
|
||||
my ( $tag, $algo, $type, $digest ) = split( /,/, $str );
|
||||
push @data, { keytag => $tag, algorithm => $algo, type => $type, digest => $digest };
|
||||
}
|
||||
|
||||
Zonemaster::Engine->add_fake_ds( $domain => \@data );
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub print_versions {
|
||||
say 'Zonemaster-CLI version ' . __PACKAGE__->VERSION;
|
||||
say 'Zonemaster-Engine version ' . $Zonemaster::Engine::VERSION;
|
||||
say 'Zonemaster-LDNS version ' . $Zonemaster::LDNS::VERSION;
|
||||
say 'NL NetLabs LDNS version ' . Zonemaster::LDNS::lib_version();
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
my @spinner_strings = ( ' | ', ' / ', ' - ', ' \\ ' );
|
||||
|
||||
sub print_spinner {
|
||||
state $counter = 0;
|
||||
state $last_spin = [ 0, 0 ];
|
||||
|
||||
my $time = [ Time::HiRes::gettimeofday() ];
|
||||
if ( Time::HiRes::tv_interval( $last_spin, $time ) > 0.1 ) {
|
||||
$last_spin = $time;
|
||||
printf "%s\r", $spinner_strings[ $counter++ % 4 ];
|
||||
}
|
||||
}
|
||||
|
||||
sub print_test_list {
|
||||
my %methods = Zonemaster::Engine->all_methods;
|
||||
my $maxlen = max map {
|
||||
map { length( $_ ) }
|
||||
@$_
|
||||
} values %methods;
|
||||
|
||||
foreach my $module ( sort keys %methods ) {
|
||||
say $module;
|
||||
foreach my $method ( sort @{ $methods{$module} } ) {
|
||||
printf " %${maxlen}s\n", $method;
|
||||
}
|
||||
print "\n";
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub do_dump_profile {
|
||||
my $json = JSON::XS->new->canonical->pretty;
|
||||
|
||||
print $json->encode( Zonemaster::Engine::Profile->effective->{q{profile}} );
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub translate_severity {
|
||||
my $severity = shift;
|
||||
if ( $severity eq "DEBUG" ) {
|
||||
return __( "DEBUG" );
|
||||
}
|
||||
elsif ( $severity eq "INFO" ) {
|
||||
return __( "INFO" );
|
||||
}
|
||||
elsif ( $severity eq "NOTICE" ) {
|
||||
return __( "NOTICE" );
|
||||
}
|
||||
elsif ( $severity eq "WARNING" ) {
|
||||
return __( "WARNING" );
|
||||
}
|
||||
elsif ( $severity eq "ERROR" ) {
|
||||
return __( "ERROR" );
|
||||
}
|
||||
elsif ( $severity eq "CRITICAL" ) {
|
||||
return __( "CRITICAL" );
|
||||
}
|
||||
else {
|
||||
return $severity;
|
||||
}
|
||||
} ## end sub translate_severity
|
||||
|
||||
sub _max {
|
||||
my ( $a, $b ) = @_;
|
||||
$a //= 0;
|
||||
$b //= 0;
|
||||
return ( $a > $b ? $a : $b );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::CLI - run Zonemaster tests from the command line
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Vincent Levigneron <vincent.levigneron at nic.fr>
|
||||
- Current maintainer
|
||||
|
||||
Calle Dybedahl <calle at init.se>
|
||||
- Original author
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This is free software under a 2-clause BSD license. The full text of the license can
|
||||
be found in the F<LICENSE> file included with this distribution.
|
||||
|
||||
=cut
|
||||
271
zonemaster-cli/lib/Zonemaster/CLI/TestCaseSet.pm
Normal file
271
zonemaster-cli/lib/Zonemaster/CLI/TestCaseSet.pm
Normal file
@@ -0,0 +1,271 @@
|
||||
package Zonemaster::CLI::TestCaseSet;
|
||||
use 5.014;
|
||||
use warnings;
|
||||
use utf8;
|
||||
|
||||
use Carp qw( croak );
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::CLI::TestCaseSet - Manage and modify Zonemaster test case selections
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Zonemaster::CLI::TestCaseSet;
|
||||
|
||||
# Define the names of the available test modules and their test cases
|
||||
my $schema = {
|
||||
alpha => [qw( alpha01 alpha02 alpha03 )],
|
||||
beta => [qw( beta01 beta02 )],
|
||||
};
|
||||
|
||||
# Construct an initial selection of test cases
|
||||
my $selection = Zonemaster::CLI::TestCaseSet->new(
|
||||
[qw( alpha01 alpha02 alpha03 beta01 )],
|
||||
$schema,
|
||||
);
|
||||
|
||||
# Parse and apply a modifier expression
|
||||
my @modifiers = Zonemaster::CLI::TestCaseSet->parse_modifier_expr( '-alpha+alpha02' );
|
||||
while ( @modifiers ) {
|
||||
my ( $op, $term ) = splice @modifiers, 0, 2;
|
||||
$selection->apply_modifier( $op, $term )
|
||||
or die "Error: Unrecognized term '$term'.\n";
|
||||
}
|
||||
|
||||
# Output final test case selection
|
||||
print join( ' ', $selection->to_list ); # alpha02 beta01
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Zonemaster::CLI::TestCaseSet represents a mutable selection of test cases,
|
||||
together with an immutable schema defining available test modules and their
|
||||
associated test cases.
|
||||
|
||||
The schema is defined as a mapping of test module names to their associated test
|
||||
case names.
|
||||
|
||||
The selection can be adjusted using modifier expressions.
|
||||
|
||||
=head2 MODIFIER EXPRESSIONS
|
||||
|
||||
A modifier expression describes a change to the current selection.
|
||||
Expressions combine terms using operators, e.g., C<'-alpha+alpha02'>.
|
||||
|
||||
These operators are supported:
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<'+'> (union)
|
||||
|
||||
Add test cases to the current selection.
|
||||
The set of test cases to add is the expansion of C<$term>.
|
||||
|
||||
=item C<'-'> (difference)
|
||||
|
||||
Remove test cases from the current selection.
|
||||
The set of test cases to remove is the expansion of C<$term>.
|
||||
|
||||
=item C<''> (replace)
|
||||
|
||||
Replace the current selection.
|
||||
The new selection is the set of test cases expanded from C<$term>.
|
||||
|
||||
=back
|
||||
|
||||
Terms expand into sets of test cases in one of three ways:
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<all>
|
||||
|
||||
Expands to all available test cases defined by the schema.
|
||||
|
||||
=item Test module name
|
||||
|
||||
Expands to all test cases associated with the test module.
|
||||
|
||||
=item Test case name
|
||||
|
||||
Expands directly to the specified test case itself.
|
||||
Test cases may be specified plainly (e.g., C<Case10>) or fully qualified
|
||||
(module/testcase, e.g., C<Case/Case10>).
|
||||
|
||||
=back
|
||||
|
||||
Term matching is case-insensitive.
|
||||
|
||||
=cut
|
||||
|
||||
=head1 CONSTRUCTORS
|
||||
|
||||
=head2 new( $selection, $schema )
|
||||
|
||||
Construct a new TestCaseSet object.
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<$selection> (arrayref)
|
||||
|
||||
Initial selection of test case names.
|
||||
|
||||
=item C<$schema> (hashref)
|
||||
|
||||
A hash mapping test module names to arrays of their associated test case names.
|
||||
|
||||
=back
|
||||
|
||||
Dies if:
|
||||
- Any test case name in C<$schema> is repeated.
|
||||
- C<$selection> contains names not found in C<$schema>.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ( $class, $selection, $schema ) = @_;
|
||||
|
||||
my %cases = map { lc $_ => 1 } map { @{$_} } values %$schema;
|
||||
for my $case ( @$selection ) {
|
||||
if ( !exists $cases{ lc $case } ) {
|
||||
croak "Unrecognized initial test case '$case'";
|
||||
}
|
||||
}
|
||||
|
||||
my $obj = {
|
||||
_selection => { map { lc $_ => 1 } @$selection },
|
||||
_terms => _get_schema_terms( $schema ),
|
||||
};
|
||||
|
||||
bless $obj, $class;
|
||||
|
||||
return $obj;
|
||||
}
|
||||
|
||||
=head1 CLASS METHODS
|
||||
|
||||
parse_modifier_expr( $modifier_expr )
|
||||
|
||||
Parse a string containing a modifier expression and returns a list of
|
||||
alternating operators and terms.
|
||||
|
||||
The returned list always starts with an operator.
|
||||
|
||||
For example, parsing C<'-alpha+beta02'> returns:
|
||||
|
||||
('-', 'alpha', '+', 'beta02')
|
||||
|
||||
=cut
|
||||
|
||||
sub parse_modifier_expr {
|
||||
my ( $class, $modifier_expr ) = @_;
|
||||
|
||||
my @modifiers;
|
||||
for my $op_and_term ( split /(?=[+-])/, $modifier_expr ) {
|
||||
$op_and_term =~ /([+-]?)(.*)/;
|
||||
my ( $op, $term ) = ( $1, $2 );
|
||||
|
||||
push @modifiers, ( $op, $term );
|
||||
}
|
||||
|
||||
return @modifiers;
|
||||
}
|
||||
|
||||
=head1 INSTANCE METHODS
|
||||
|
||||
=head2 apply_modifier( $operator, $term )
|
||||
|
||||
Update the selection using the given operator and term.
|
||||
|
||||
Returns true if successful, or false if the term could not be expanded based on
|
||||
the schema.
|
||||
|
||||
Dies if the operator is invalid.
|
||||
|
||||
=head3 Example:
|
||||
|
||||
$selection->apply_modifier('+', 'beta')
|
||||
or die "Unrecognized term";
|
||||
|
||||
=cut
|
||||
|
||||
sub apply_modifier {
|
||||
my ( $self, $op, $term ) = @_;
|
||||
|
||||
my $cases_ref = $self->{_terms}{ lc $term };
|
||||
|
||||
if ( !defined $cases_ref ) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
if ( $op eq '' ) {
|
||||
$self->{_selection} = {};
|
||||
$op = '+';
|
||||
}
|
||||
|
||||
if ( $op eq '-' ) {
|
||||
for my $case ( @$cases_ref ) {
|
||||
delete $self->{_selection}{$case};
|
||||
}
|
||||
}
|
||||
elsif ( $op eq '+' ) {
|
||||
for my $case ( @$cases_ref ) {
|
||||
$self->{_selection}{$case} = 1;
|
||||
}
|
||||
}
|
||||
else {
|
||||
croak "Unrecognized operator '$op'";
|
||||
}
|
||||
|
||||
return 1;
|
||||
} ## end sub apply_modifier
|
||||
|
||||
=head2 to_list
|
||||
|
||||
Return a lowercase list of the currently selected test case names.
|
||||
|
||||
=cut
|
||||
|
||||
sub to_list {
|
||||
my ( $self ) = @_;
|
||||
|
||||
return sort keys %{ $self->{_selection} };
|
||||
}
|
||||
|
||||
sub _get_schema_terms {
|
||||
my ( $schema ) = @_;
|
||||
|
||||
my $terms = {};
|
||||
$terms->{all} = [];
|
||||
|
||||
for my $module ( keys %$schema ) {
|
||||
if ( lc $module eq 'all' ) {
|
||||
croak "test module name must not be 'all'";
|
||||
}
|
||||
if ( $module =~ qr{/} ) {
|
||||
croak "test module name contains forbidden character '/': '$module'";
|
||||
}
|
||||
if ( exists $terms->{ lc $module } ) {
|
||||
croak "found test module with same name as another test case or test module: '$module'";
|
||||
}
|
||||
$terms->{ lc $module } = [];
|
||||
for my $case ( @{ $schema->{$module} } ) {
|
||||
if ( lc $case eq 'all' ) {
|
||||
croak "test case name must not be 'all'";
|
||||
}
|
||||
if ( $case =~ qr{/} ) {
|
||||
croak "test case name contains forbidden character '/': '$case'";
|
||||
}
|
||||
if ( exists $terms->{ lc $case } ) {
|
||||
croak "found test case with same name as another test case or test module: '$case'";
|
||||
}
|
||||
$terms->{ lc $case } = [$case];
|
||||
$terms->{ lc "$module/$case" } = [$case];
|
||||
push @{ $terms->{ lc $module } }, $case;
|
||||
push @{ $terms->{all} }, $case;
|
||||
}
|
||||
} ## end for my $module ( keys %$schema)
|
||||
|
||||
return $terms;
|
||||
} ## end sub _get_schema_terms
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user