The Perl Toolchain Summit 2025 Needs You: You can help 🙏 Learn more

use strict;
use FindBin qw/$RealBin/;
use Log::Any qw/$log/;
my $tests = 0;
my $dir_name = [File::Spec->splitpath($0)]->[2];
$dir_name =~ s/\.t//;
my $samples_dir = File::Spec->catdir($RealBin, '/samples/', $dir_name);
my $truth_file = File::Spec->catfile($samples_dir, 'values.yml');
ok(-f $truth_file, $truth_file . ": truth file exists"); $tests++;
my $truth_data = YAML::Any::LoadFile($truth_file);
isa_ok($truth_data, 'HASH', 'truth data loaded'); $tests++;
my $correct;
foreach my $filepath (glob("$samples_dir/*.pl")) {
$log->clear;
my $file = [File::Spec->splitpath($filepath)]->[2];
my $ok = 1;
$correct = $truth_data->{$file};
isnt ($correct, undef, $file . ': truth value is valid');
isa_ok($correct, 'HASH', $file . ': truth value is hashref');
my $version = delete $correct->{version};
isnt(exists($correct->{version}), 'version deleted from truth hash ok');
my $obj = obj($filepath, 0);
$ok = ok($obj->parse, "$file: parsed ok");
is($obj->version, $version, $file . ': version is correct');
my $meta = $obj->metadata;
my @keys = sort keys %$meta;
$ok = isa_ok($meta, 'HASH', $file . ': metadata is a hashref');
$ok = cmp_ok(@keys, '>', 0, $file . ': has some keys');
my @correct_keys = sort keys %$correct;
$ok = eq_or_diff(\@keys, \@correct_keys, $file . ': keys match with expected');
$tests += 8;
foreach my $key (@keys) {
my $m_val = $meta->{$key};
my $c_val = $correct->{$key};
$ok = eq_or_diff($m_val, $c_val,
"$file: values for key: '$key' are correct");
$tests++;
}
dump_logs() unless $ok;
}
done_testing $tests;
sub obj {
my ($name, $split) = @_;
$split //= 1;
my $obj = new_ok 'Irssi::Script::InfoParser', [file => $name,
split_authors => $split];
$tests++;
return $obj;
}
sub dump_logs {
my $msgs_aref = $log->msgs;
my @msgs = @{$msgs_aref};
diag("Dumping Log info, num: " . scalar(@msgs));
diag("-------------------------- start of messages ------------");
foreach my $msg_href (@msgs) {
my %msg_hash = %{$msg_href};
my ($cat, $lvl, $msg) = @msg_hash{qw/category level message/};
diag sprintf("[% 6s] %s", $lvl, $msg);
}
diag("-------------------------- end of messages ---------------");
$log->clear;
die "something failed" if $ENV{LOGGING_FATAL};
1;
}