File Coverage

blib/lib/Config/Model/Tester.pm

Criterion	Covered	Total	%
statement	67	415	16.1
branch	6	202	2.9
condition	2	74	2.7
subroutine	17	46	36.9
pod	0	24	0.0
total	92	761	12.0

#
# This file is part of Config-Model-Tester
#
# This software is Copyright (c) 2013-2020 by Dominique Dumont.
#
# This is free software, licensed under:
#
#   The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Tester 4.006;
# ABSTRACT: Test framework for Config::Model

use warnings;
use strict;
use locale;
use utf8;
use 5.12.0;

use Test::More;
use Log::Log4perl 1.11 qw(:easy :levels);
use Path::Tiny;
use File::Copy::Recursive qw(fcopy rcopy dircopy);

use Test::Warn;
use Test::Exception;
use Test::File::Contents ;
use Test::Differences;
use Test::Memory::Cycle ;

use Config::Model::Tester::Setup qw/init_test setup_test_dir/;

# use eval so this module does not have a "hard" dependency on Config::Model
# This way, Config::Model can build-depend on Config::Model::Tester without
# creating a build dependency loop.
eval {
    require Config::Model;
    require Config::Model::Lister;
    require Config::Model::Value;
    require Config::Model::BackendMgr;
} ;

use vars qw/@ISA @EXPORT/;

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(run_tests);

$File::Copy::Recursive::DirPerms = oct(755);

sub setup_test {
    my ( $test_group, $t_name, $wr_root, $trace, $test_suite_data, $t_data ) = @_;

    # cleanup before tests
    $wr_root->remove_tree();
    $wr_root->mkpath( { mode => oct(755) } );
    my ($conf_dir, $conf_file_name, $home_for_test)
        = @$test_suite_data{qw/conf_dir conf_file_name home_for_test/};

    if ($conf_dir and $home_for_test) {
        $conf_dir =~ s!~/!$home_for_test/!;
        $test_suite_data->{conf_dir} = $conf_dir;
    }

    my $wr_dir    = $wr_root->child('test-' . $t_name);
    my $wr_dir2   = $wr_root->child('test-' . $t_name.'-w');
    $wr_dir->mkpath;
    $wr_dir2->mkpath;

    my $conf_file ;
    $conf_file = $wr_dir->child($conf_dir,$conf_file_name)
        if $conf_dir and $conf_file_name;

    my $ex_dir = path('t')->child('model_tests.d', "$test_group-examples");
    my $ex_data = $ex_dir->child($t_data->{data_from} // $t_name);

    my @file_list;

    if (my $setup = $t_data->{setup}) {
        foreach my $file (keys %$setup) {
            my $map = $setup->{$file} ;
            my $destination_str
                = ref ($map) eq 'HASH' ? $map->{$^O} // $map->{default}
                : ref ($map) eq 'ARRAY' ? $map->[-1]
                :                        $map;
            if (not defined $destination_str) {
                die "$test_group $t_name setup error: cannot find destination for test file $file" ;
            }
            $destination_str =~ s!~/!$home_for_test/! if $home_for_test;
            my $destination = $wr_dir->child($destination_str) ;
            $destination->parent->mkpath( { mode => oct(755) }) ;
            my $data_file = $ex_data->child($file);
            die "cannot find $data_file" unless $data_file->exists;
            my $data = $data_file->slurp() ;
            $destination->spew( $data );
            if (ref $map eq 'ARRAY') {
                my @tmp = @$map;
                pop @tmp; # remove destination
                foreach my $link_str (@tmp) {
                    $link_str =~ s!~/!$home_for_test/! if $home_for_test;
                    my $link = $wr_dir->child($link_str);
                    $link->parent->mkpath( { mode => oct(755) }) ;
                    symlink $destination->absolute->stringify, $link->stringify;
                }
            }
            @file_list = list_test_files ($wr_dir);
        }
    }
    elsif ( $ex_data->is_dir ) {
        # copy whole dir
        my $destination_dir = $conf_dir ? $wr_dir->child($conf_dir) : $wr_dir ;
        $destination_dir->mkpath( { mode => oct(755) });
        say "dircopy ". $ex_data->stringify . '->'. $destination_dir->stringify
            if $trace ;
        dircopy( $ex_data->stringify, $destination_dir->stringify )
          || die "dircopy $ex_data -> $destination_dir failed:$!";
        @file_list = list_test_files ($destination_dir);
    }
    elsif ( $ex_data->exists ) {
        # either one if true if $conf_file is undef
        die "test data is missing global \$conf_dir" unless defined $conf_dir;
        die "test data is missing global \$conf_file_name" unless defined $conf_file;

        # just copy file
        say "file copy ". $ex_data->stringify . '->'. $conf_file->stringify
            if $trace ;
        fcopy( $ex_data->stringify, $conf_file->stringify )
          || die "copy $ex_data -> $conf_file failed:$!";
    }
    else {
        note ('starting test without original config data, i.e. from scratch');
    }
    ok( 1, "Copied $test_group example $t_name" );

    return ( $wr_dir, $wr_dir2, $conf_file, $ex_data, @file_list );
}

#
# New subroutine "list_test_files" extracted - Thu Nov 17 17:27:20 2011.
#
sub list_test_files {
    my $debian_dir = shift;
    my @file_list ;

    my $iter = $debian_dir->iterator({ recurse => 1 });
    my $debian_str = $debian_dir->stringify;

	while ( my $child = $iter->() ) {
		next if $child->is_dir ;

		push @file_list, '/' . $child->relative($debian_str)->stringify;
	};

    # don't use return sort -> undefined behavior in scalar context.
    my @res = sort @file_list;
    return @res;
}

sub write_config_file {
    my ($conf_dir,$wr_dir,$t) = @_;

    if ($t->{config_file}) {
        my $file = $conf_dir ? "$conf_dir/" : '';
        $file .= $t->{config_file} ;
        $wr_dir->child($file)->parent->mkpath({mode => oct(755)} ) ;
    }
}

sub check_load_warnings {
    my ($root,$t) = @_ ;

    if ( my $info = $t->{log4perl_load_warnings} or $::_use_log4perl_to_warn) {
        my $tw = Test::Log::Log4perl->expect( @{ $info // [] } );
        $root->init;
    }
    elsif ( ($t->{no_warnings} or exists $t->{load_warnings}) and not defined $t->{load_warnings}) {
        local $Config::Model::Value::nowarning = 1;
        $root->init;
        note("load_warnings param is DEPRECATED. Please use log4perl_load_warnings");
        ok( 1,"Read configuration and created instance with init() method without warning check" );
    }
    else {
        warnings_like { $root->init; } $t->{load_warnings},
            "Read configuration and created instance with init() method with warning check ";
    }
}

sub run_update {
    my ($inst, $dir, $t) = @_;
    my %args = %{$t->{update}};

    my $ret = delete $args{returns};

    local $Config::Model::Value::nowarning = $args{no_warnings} || $t->{no_warnings} || 0;

    my $res ;
    if ( my $info = $t->{log4perl_update_warnings}) {
        my $tw = Test::Log::Log4perl->expect( $info );
        note("updating config with log4perl warning check and args: ". join(' ',%args));
        $res = $inst->update( from_dir => $dir, %args ) ;
    }
    elsif (my $uw = delete $args{update_warnings}) {
        note("update_warnings param is DEPRECATED. Please use log4perl_update_warnings");
        note("updating config with warning check and args: ". join(' ',%args));
        warnings_like { $res = $inst->update( from_dir => $dir, %args ); } $uw,
            "Updated configuration with warning check ";
    }
    else {
        note("updating config with no warning check and args: ". join(' ',%args));
        $res = $inst->update( from_dir => $dir, %args ) ;
    }

    if (defined $ret) {
        is($res,$ret,"updated configuration, got expected return value");
    }
    else {
        ok(1,"dumped configuration");
    }
}

sub load_instructions {
    my ($root,$steps,$trace) = @_ ;

    print "Loading $steps\n" if $trace ;
    $root->load( $steps );
    ok( 1, "load called" );
}

sub apply_fix {
    my $inst = shift;
    local $Config::Model::Value::nowarning = 1;
    $inst->apply_fixes;
    ok( 1, "apply_fixes called" );
}

sub dump_tree {
    my ($test_group, $root, $mode, $no_warnings, $t, $test_logs, $trace) = @_;

    print "dumping tree ...\n" if $trace;
    my $dump  = '';
    my $risky = sub {
        $dump = $root->dump_tree( mode => $mode );
    };

    if ( defined $t->{dump_errors} ) {
        my $nb = 0;
        my @tf = @{ $t->{dump_errors} };
        while (@tf) {
            my $qr = shift @tf;
            throws_ok { &$risky } $qr, "Failed dump $nb of $test_group config tree";
            my $fix = shift @tf;
            $root->load($fix);
            ok( 1, "Fixed error nb " . $nb++ );
        }
    }

    if ( $test_logs and (my $info = $t->{log4perl_dump_warnings} or $::_use_log4perl_to_warn)) {
        note("checking logged warning while dumping");
        my $tw = Test::Log::Log4perl->expect( @{$info // [] } );
        $risky->();
    }
    elsif ( not $test_logs or $no_warnings ) {
        local $Config::Model::Value::nowarning = 1;
        &$risky;
        ok( 1, "Ran dump_tree (no warning check)" );
    }
    elsif ( exists $t->{dump_warnings} and not defined $t->{dump_warnings} ) {
        local $Config::Model::Value::nowarning = 1;
        &$risky;
        ok( 1, "Ran dump_tree with DEPRECATED dump_warnings parameter (no warning check)" );
    }
    else {
        note("dump_warnings parameter is DEPRECATED") if $t->{dump_warnings};
        warnings_like { &$risky; } $t->{dump_warnings}, "Ran dump_tree";
    }
    ok( $dump, "Dumped $test_group config tree in $mode mode" );

    print $dump if $trace;
    return $dump;
}

sub check_data {
    my ($label, $root, $c, $nw) = @_;

    local $Config::Model::Value::nowarning = $nw || 0;
    my @checks = ref $c eq 'ARRAY' ? @$c
        : map { ( $_ => $c->{$_})} sort keys %$c ;

    while (@checks) {
        my $path       = shift @checks;
        my $v          = shift @checks;
        check_one_item($label, $root,$path, $v);
    }
}

sub check_one_item {
    my ($label, $root,$path, $check_data_l) = @_;

    my @checks = ref $check_data_l eq 'ARRAY' ? @$check_data_l : ($check_data_l);

    foreach my $check_data (@checks) {
        my $check_v_l  = ref $check_data eq 'HASH' ? delete $check_data->{value} : $check_data;
        my @check_args = ref $check_data eq 'HASH' ? %$check_data : ();
        my $check_str  = @check_args ? " (@check_args)" : '';
        my $obj = $root->grab( step => $path, type => ['leaf','check_list'], @check_args );
        my $got = $obj->fetch(@check_args);

        my @check_v = ref($check_v_l) eq 'ARRAY' ? @$check_v_l : ($check_v_l);
        foreach my $check_v (@check_v) {
            if (ref $check_v eq 'Regexp') {
                like( $got, $check_v, "$label check '$path' value with regexp$check_str" );
            }
            else {
                is( $got, $check_v, "$label check '$path' value$check_str" );
            }
        }
    }
}

sub check_annotation {
    my ($root, $t) = @_;

    my $annot_check = $t->{verify_annotation};
    foreach my $path (keys %$annot_check) {
        my $note = $annot_check->{$path};
        is( $root->grab($path)->annotation, $note, "check $path annotation" );
    }
}

sub has_key {
    my ($root, $c, $nw) = @_;

    _test_key($root, $c, $nw, 0);
}

sub has_not_key {
    my ($root, $c, $nw) = @_;

    _test_key($root, $c, $nw, 1);
}

sub _test_key {
    my ($root, $c, $nw, $invert) = @_;

    my @checks = ref $c eq 'ARRAY' ? @$c
        : map { ( $_ => $c->{$_})} sort keys %$c ;

    while (@checks) {
        my $path       = shift @checks;
        my $spec       = shift @checks;
        my @key_checks = ref $spec eq 'ARRAY' ? @$spec: ($spec);

        my $obj = $root->grab( step => $path, type => 'hash' );
        my @keys = $obj->fetch_all_indexes;
        my $res = 0;
        foreach my $check (@key_checks) {
            my @match  ;
            foreach my $k (@keys) {
                if (ref $check eq 'Regexp') {
                    push @match, $k if $k =~ $check;
                }
                else {
                    push @match, $k if $k eq $check;
                }
            }
            if ($invert) {
                is(scalar @match,0, "check $check matched no key" );
            }
            else {
                ok(scalar @match, "check $check matched with keys @match" );
            }
        }
    }
}

sub write_data_back {
    my ($test_group, $inst, $t) = @_;
    local $Config::Model::Value::nowarning = $t->{no_warnings} || 0;
    $inst->write_back( force => 1 );
    ok( 1, "$test_group write back done" );
}

sub check_file_mode {
    my ($wr_dir, $t) = @_;

    if ($^O eq 'MSWin32' and my $fm = $t->{file_mode}) {
        note("skipping file mode tests on Windows");
        return;
    }

    if (my $fm = $t->{file_mode}) {
        foreach my $f (keys %$fm) {
            my $expected_mode = $fm->{$f} ;
            my $stat = $wr_dir->child($f)->stat;
            ok($stat ,"stat found file $f");
            if ($stat) {
                my $mode = $stat->mode & oct(7777) ;
                is($mode, $expected_mode, sprintf("check $f mode (got %o vs %o)",$mode,$expected_mode));
            }
        }
    }
}

sub check_file_content {
    my ($wr_dir, $t) = @_;

    if (my $fc = $t->{file_contents} || $t->{file_content}) {
        foreach my $f (keys %$fc) {
            my $t = $fc->{$f} ;
            my @tests = ref $t eq 'ARRAY' ? @$t : ($t) ;
            foreach my $subtest (@tests) {
                file_contents_eq_or_diff $wr_dir->child($f)->stringify,  $subtest, { encoding => 'UTF-8' },
                    "check that $f contains $subtest";
            }
        }
    }

    if (my $fc = $t->{file_contents_like}) {
        foreach my $f (keys %$fc) {
            my $t = $fc->{$f} ;
            my @tests = ref $t eq 'ARRAY' ? @$t : ($t) ;
            foreach my $subtest (@tests) {
                file_contents_like $wr_dir->child($f)->stringify,  $subtest, { encoding => 'UTF-8' },
                    "check that $f matches regexp $subtest";
            }
        }
    }

    if (my $fc = $t->{file_contents_unlike}) {
        foreach my $f (keys %$fc) {
            my $t = $fc->{$f} ;
            my @tests = ref $t eq 'ARRAY' ? @$t : ($t) ;
            foreach my $subtest (@tests) {
                file_contents_unlike $wr_dir->child($f)->stringify,  $subtest, { encoding => 'UTF-8' },
                    "check that $f does not match regexp $subtest";
            }
        }
    }
}

sub check_added_or_removed_files {
    my ( $conf_dir, $wr_dir, $t, @file_list) = @_;

    # copy whole dir
    my $destination_dir
        = $t->{setup} ? $wr_dir
        : $conf_dir   ? $wr_dir->child($conf_dir)
        :               $wr_dir ;
    my @new_file_list = list_test_files($destination_dir) ;
    $t->{file_check_sub}->( \@file_list ) if defined $t->{file_check_sub};
    eq_or_diff( \@new_file_list, [ sort @file_list ], "check added or removed files" );
}

sub create_second_instance {
    my ($model, $test_group, $t_name, $wr_dir, $wr_dir2, $test_suite_data, $t, $config_dir_override) = @_;

    # create another instance to read the conf file that was just written
    dircopy( $wr_dir->stringify, $wr_dir2->stringify )
        or die "can't copy from $wr_dir to $wr_dir2: $!";

    my @options;
    push @options, backend_arg => $t->{backend_arg} if $t->{backend_arg};

    my $i2_test = $model->instance(
        root_class_name => $test_suite_data->{model_to_test},
        root_dir        => $wr_dir2->stringify,
        config_file     => $t->{config_file} ,
        instance_name   => "$test_group-$t_name-w",
        application     => $test_suite_data->{app_to_test},
        check           => $t->{load_check2} || 'yes',
        config_dir      => $config_dir_override,
        @options
    );

    ok( $i2_test, "Created instance $test_group-test-$t_name-w" );

    local $Config::Model::Value::nowarning = $t->{no_warnings} || 0;
    my $i2_root = $i2_test->config_root;
    $i2_root->init;

    return $i2_root;
}

sub create_test_class {
    my ($model, $config_classes) = @_;
    return unless $config_classes;

    foreach my $c ( @$config_classes) {
        my @parms = ref($c) eq 'HASH' ? %$c : @$c;
        $model->create_config_class(@parms);
    }
}

our ($model, $conf_file_name, $conf_dir, $model_to_test, $app_to_test, $home_for_test, @tests, $skip);

sub load_test_suite_data {
    my ($model_obj, $test_group, $test_group_conf) = @_;

    local ($model, $conf_file_name, $conf_dir, $model_to_test, $app_to_test, $home_for_test, @tests, $skip);

    $skip = 0;
    undef $conf_file_name ;
    undef $conf_dir ;
    undef $home_for_test ;
    undef $model_to_test ; # deprecated
    undef $app_to_test;
    $model = $model_obj; # $model is used by Config::Model tests

    note("Beginning $test_group test ($test_group_conf)");

    my $result;
    unless ( $result = do "./$test_group_conf" ) {
        warn "couldn't parse $test_group_conf: $@" if $@;
        warn "couldn't do $test_group_conf: $!" unless defined $result;
        warn "couldn't run $test_group_conf" unless $result;
    }

    my $test_suite_data;
    if (ref($result) eq 'ARRAY') {
        # simple list of tests
        $test_suite_data = { tests => $result };
    }
    elsif (ref($result) eq 'HASH') {
        $test_suite_data = $result;
    }
    else {
        note(qq!warning: $test_group_conf should return a data structure instead of "1;". !
                 . qq!See Config::Model::Tester for details!);
        $test_suite_data = {
            tests => [ @tests ],
            skip => $skip,
            conf_file_name  => $conf_file_name ,
            conf_dir  => $conf_dir ,
            home_for_test  => $home_for_test ,
            model_to_test => $model_to_test,
            app_to_test => $app_to_test,
        };
    }

    create_test_class($model, $test_suite_data->{config_classes});

    $test_suite_data->{app_to_test} ||= $test_group;

    if ($test_suite_data->{skip}) {
        note("Skipped $test_group test ($test_group_conf)");
        return;
    }

    my ($trash, $appli_info, $applications) = Config::Model::Lister::available_models(1);
    $test_suite_data->{appli_info} = $appli_info;

    # even undef, this resets the global variable there
    Config::Model::BackendMgr::_set_test_home($test_suite_data->{home_for_test}) ;

    if (not defined $test_suite_data->{model_to_test}) {
        $test_suite_data->{model_to_test} = $applications->{$test_suite_data->{app_to_test}};
        if (not defined $test_suite_data->{model_to_test}) {
            my @k = sort values %$applications;
            my @files = map { $_->{_file} // 'unknown' } values %$appli_info ;
            die "Cannot find application or model for $test_group in files >@files<. Known applications are",
                sort keys %$applications, ". Known models are >@k<. ".
                "Check your test name (the file ending with -test-conf.pl) or set app_to_test parameter\n";
        }
    }

    return $test_suite_data;
}

sub run_model_test {
    my ($test_group, $test_group_conf, $do, $model, $trace, $wr_root, $test_logs) = @_ ;

    my $test_suite_data = load_test_suite_data($model,$test_group, $test_group_conf);
    my $appli_info = $test_suite_data->{appli_info};

    my $config_dir_override = $appli_info->{$test_group}{config_dir}; # may be undef

    my $note ="$test_group uses ".$test_suite_data->{model_to_test}." model";
    my $conf_file_name = $test_suite_data->{conf_file_name};
    $note .= " on file $conf_file_name" if defined $conf_file_name;
    note($note);

    my $idx = 0;
    foreach my $t (@{$test_suite_data->{tests}}) {
        translate_test_data($t);
        my $t_name = $t->{name} || "t$idx";
        if ( defined $do and $t_name !~ /$do/) {
            $idx++;
            next;
        }
        note("Beginning subtest $test_group $t_name");

        my ($wr_dir, $wr_dir2, $conf_file, $ex_data, @file_list)
            = setup_test ($test_group, $t_name, $wr_root,$trace, $test_suite_data, $t);

        write_config_file($test_suite_data->{conf_dir},$wr_dir,$t);

        my $inst_name = "$test_group-" . $t_name;

        die "Duplicated test name $t_name for app $test_group\n"
            if $model->has_instance ($inst_name);

        my @options;
        push @options, backend_arg => $t->{backend_arg} if $t->{backend_arg};

        # eventually, we may end up with several instances of Dpkg
        # model in the same process. So we can't play with chdir
        my $inst = $model->instance(
            root_class_name => $test_suite_data->{model_to_test},
            # need to keed root_dir to handle config files like
            # /etc/foo.ini (absolute path, like in /etc/)
            root_dir        => $wr_dir->stringify,
            instance_name   => $inst_name,
            application     => $test_suite_data->{app_to_test},
            config_file     => $t->{config_file} ,
            check           => $t->{load_check} || 'yes',
            config_dir      => $config_dir_override,
            @options
        );

        my $root = $inst->config_root;

        check_load_warnings ($root,$t) if $test_logs;

        run_update($inst,$wr_dir,$t) if $t->{update};

        load_instructions ($root,$t->{load},$trace) if $t->{load} ;

        dump_tree ('before fix '.$test_group , $root, 'full', $t->{no_warnings}, $t->{check_before_fix}, $test_logs, $trace)
            if $t->{check_before_fix};

        apply_fix($inst) if  $t->{apply_fix};

        dump_tree ($test_group, $root, 'full', $t->{no_warnings}, $t->{full_dump}, $test_logs, $trace) ;

        my $dump = dump_tree ($test_group, $root, 'custom', $t->{no_warnings}, {}, $test_logs, $trace) ;

        check_data("first", $root, $t->{check}, $t->{no_warnings}) if $t->{check};

        has_key     ( $root, $t->{has_key}, $t->{no_warnings}) if $t->{has_key} ;
        has_not_key ( $root, $t->{has_not_key}, $t->{no_warnings}) if $t->{has_not_key} ;

        check_annotation($root,$t) if $t->{verify_annotation};

        write_data_back ($test_group, $inst, $t) ;

        check_file_content($wr_dir,$t) ;

        check_file_mode($wr_dir,$t) ;

        check_added_or_removed_files ($test_suite_data->{conf_dir}, $wr_dir, $t, @file_list) if $ex_data->is_dir;

        my $i2_root = create_second_instance ($model, $test_group, $t_name, $wr_dir, $wr_dir2, $test_suite_data, $t, $config_dir_override);

        load_instructions ($i2_root,$t->{load2},$trace) if $t->{load2} ;

        my $p2_dump = dump_tree("second $test_group", $i2_root, 'custom', $t->{no_warnings},{}, $test_logs, $trace) ;

        unified_diff;
        eq_or_diff(
            [ split /\n/,$p2_dump ],
            [ split /\n/,$dump ],
            "compare original $test_group custom data with 2nd instance custom data",
        );

        ok( -s "$wr_dir2/$test_suite_data->{conf_dir}/$test_suite_data->{conf_file_name}" ,
            "check that original $test_group file was not clobbered" )
                if defined $test_suite_data->{conf_file_name} ;

        check_data("second", $i2_root, $t->{wr_check}, $t->{no_warnings}) if $t->{wr_check} ;

        note("End of subtest $test_group $t_name");

        $idx++;
    }
    note("End of $test_group test");

}

sub translate_test_data {
    my $t = shift;
    map {$t->{full_dump}{$_} = delete $t->{$_} if $t->{$_}; } qw/dump_warnings dump_errors/;
}

sub create_model_object {
    my $new_model ;
    eval { $new_model = Config::Model->new(); } ;
    if ($@) {
        # necessary to run smoke test (no Config::Model to avoid dependency loop)
        plan skip_all => 'Config::Model is not loaded' ;
        return;
    }
    return $new_model;
}

sub run_tests {
    my ( $test_only_app, $do, $trace, $wr_root );
    my $model;
    my $test_logs;
    if (@_) {
        my $arg;
        note ("Calling run_tests with argument is deprecated");
        ( $arg, $test_only_app, $do ) = @_;

        my $log = 0;

        $trace = ($arg =~ /t/) ? 1 : 0;
        $log  = 1 if $arg =~ /l/;

        my $log4perl_user_conf_file = ($ENV{HOME} || '') . '/.log4config-model';

        if ( $log and -e $log4perl_user_conf_file ) {
            Log::Log4perl::init($log4perl_user_conf_file);
        }
        else {
            Log::Log4perl->easy_init( $log ? $WARN : $ERROR );
        }

        Config::Model::Exception::Any->Trace(1) if $arg =~ /e/;

        ok( 1, "compiled" );

        # pseudo root where config files are written by config-model
        $wr_root = path('wr_root');
    }
    else {
        my $opts;
        ($model, $trace, $opts) = init_test();
        $test_logs = $opts->{log} ? 0 : 1;
        ( $test_only_app, $do)  = @ARGV;
        # pseudo root where config files are written by config-model
        $wr_root = setup_test_dir();
    }

    my @group_of_tests = grep { /-test-conf.pl$/ } glob("t/model_tests.d/*");

    foreach my $test_group_conf (@group_of_tests) {
        my ($test_group) = ( $test_group_conf =~ m!\.d/([\w\-]+)-test-conf! );
        next if ( $test_only_app and $test_only_app ne $test_group ) ;
        $model = create_model_object();
        return unless $model;
        run_model_test($test_group, $test_group_conf, $do, $model, $trace, $wr_root, $test_logs) ;
    }

    memory_cycle_ok($model,"test memory cycle") ;

    done_testing;

}
1;

__END__