The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use warnings;

my @n_lower = qw(loglevel log_level);
my @n_ucfirst = qw(LogLevel Log_Level);
my @n_uc = qw(LOGLEVEL LOG_LEVEL);
my @n = (@n_lower, @n_ucfirst, @n_uc);
my @outputs = qw(dir file screen syslog);
my @s_lower = qw(quiet verbose debug trace);
my @s_ucfirst = map {ucfirst} @s_lower;
my @s_uc = map {uc} @s_lower;
my @s = (@s_lower, @s_ucfirst, @s_uc);

my @global_vars = (@n, @s);
for my $o (@outputs) { push @global_vars, $o."_".$_ for @n_lower }
for my $o (@outputs) { push @global_vars, ucfirst($o)."_".$_ for @n_ucfirst }
for my $o (@outputs) { push @global_vars, uc($o)."_".$_ for @n_uc }
for my $o (@outputs) { push @global_vars, $o."_".$_ for @s_lower }
for my $o (@outputs) { push @global_vars, ucfirst($o)."_".$_ for @s_ucfirst }
for my $o (@outputs) { push @global_vars, uc($o)."_".$_ for @s_uc }

my %orig_env;
BEGIN { %orig_env = %ENV }

sub reset_vars {
    %App::options = ();
    delete $ENV{$_} for keys %ENV; $ENV{$_} = $orig_env{$_} for keys %orig_env;
    @ARGV = ();
    no strict 'refs';
    no warnings;
    for my $v (@global_vars) { $v = "main::$v"; $$v = undef }
}

sub test_init {
    my %args = @_;
    my $name = $args{name};
    my $init_args = $args{init_args} ? [@{ $args{init_args} }] : [];
    push @$init_args, -init => 0;

    reset_vars();
    $args{pre}->() if $args{pre};
    $Log::Any::App::init_called = 0;
    my $spec = Log::Any::App::init($init_args);

    if (defined $args{num_dirs}) {
        is(scalar(@{ $spec->{dir} }), $args{num_dirs}, "$name: num of dir output is $args{num_dirs}");
    }
    if (defined $args{num_files}) {
        is(scalar(@{ $spec->{file} }), $args{num_files}, "$name: num of file output is $args{num_files}");
    }
    if (defined $args{num_screens}) {
        is(scalar(@{ $spec->{screen} }), $args{num_screens}, "$name: num of screen output is $args{num_screens}");
    }
    if (defined $args{num_syslogs}) {
        is(scalar(@{ $spec->{syslog} }), $args{num_syslogs}, "$name: num of syslog output is $args{num_syslogs}");
    }

    if (defined $args{level}) {
        is(uc($spec->{level}), uc($args{level}), "$name: general level is $args{level}");
    }
    if (defined $args{dir_level}) {
        is(uc($spec->{dir}[0]{level}), uc($args{dir_level}), "$name: dir level is $args{dir_level}");
    }
    if (defined $args{file_level}) {
        is(uc($spec->{file}[0]{level}), uc($args{file_level}), "$name: file level is $args{file_level}");
    }
    if (defined $args{screen_level}) {
        is(uc($spec->{screen}[0]{level}), uc($args{screen_level}), "$name: screen level is $args{screen_level}");
    }
    if (defined $args{syslog_level}) {
        is(uc($spec->{syslog}[0]{level}), uc($args{syslog_level}), "$name: syslog level is $args{syslog_level}");
    }

    if (defined $args{dir_params}) {
        _test_params("dir", $spec->{dir}[0], $args{dir_params}, $name);
    }
    if (defined $args{file_params}) {
        _test_params("file", $spec->{file}[0], $args{file_params}, $name);
    }
    if (defined $args{screen_params}) {
        _test_params("screen", $spec->{screen}[0], $args{screen_params}, $name);
    }
    if (defined $args{syslog_params}) {
        _test_params("syslog", $spec->{syslog}[0], $args{syslog_params}, $name);
    }

    if ($args{check}) {
        $args{check}->($spec, $name);
    }
}

sub _test_params {
    my ($kind, $ospec, $params, $name) = @_;
    while (my ($k, $v) = each %$params) {
        if (ref($v) eq 'Regexp') {
            like($ospec->{$k}, $v, "$name: $kind param '$k' matches $v");
        } else {
            is  ($ospec->{$k}, $v, "$name: $kind param '$k' is $v");
        }
    }
}

1;