view release on metacpan or  search on metacpan

lib/Class/Scaffold/App/Test/YAMLDriven.pm  view on Meta::CPAN

__PACKAGE__->mk_abstract_accessors(qw(run_subtest plan_test))
  ->mk_hash_accessors(qw(test_def))->mk_scalar_accessors(
    qw(
      testdir testname expect run_num runs current_test_def
      )
  );
use constant SHARED => '00shared.yaml';
use constant GETOPT => (
    qw/
      shuffle reverse
      /
);

# 'runs' is the number of stage runs per test file ensure idempotency
use constant DEFAULTS => (
    runs    => 1,
    testdir => '.',
);

sub app_code {
    my $self = shift;
    $self->SUPER::app_code(@_);
    $self->read_test_defs;
    plan tests => $self->make_plan;
    for my $testname ($self->ordered_test_def_keys) {
        next if $testname eq SHARED;
        $self->execute_test_def($testname);
    }
}

sub read_test_defs {
    my $self = shift;

    # It's possible to pass args to the test program. If there are any
    # such args, then in order for a test file to be used its name has to
    # contain one of the args as a substring. For example, to only run
    # the policy tests whose name contains 'unnamed' or '99', you'd use:
    #
    #   perl t/10Policy.t unnamed 99
    my $name_filter = join '|' => map { "\Q$_\E" } @ARGV;
    my $testdir = $self->testdir;

    # First collect the files to process into a hash, then process that
    # hash sorted by name. This separation is necessary because some test
    # files depend on others, but find() doesn't ensure that the files are
    # returned in sorted order.
    my %file;
    find(
        sub {
            return unless -f && /\.yaml$/;
            (my $name = $File::Find::name) =~ s!^$testdir/!!;
            return
              if $name ne SHARED && $name_filter && $name !~ /$name_filter/o;
            $file{$name} = $File::Find::name;
        },
        $testdir
    );
    for my $name (sort keys %file) {
        note "Loading test file $name";
        (   my $tests_yaml =
              do { local (@ARGV, $/) = $file{$name}; <> }
        ) =~ s/%%PID%%/sprintf("%06d", $$)/ge;
        $tests_yaml =~ s/%%CNT%%/sprintf("%03d", ++(our $cnt))/ge;

        # Quick regex check whether the test wants to be skipped. To use
        # Load() on a test that wants to be skipped would be a bad idea as it
        # might be work in progress; it will be skipped for a reason.
        if ($tests_yaml =~ /^skip:\s*1/m) {
            note 'Test wants to be skipped, no activation';
        } else {

            # support for value classes
            local $Class::Value::SkipChecks = 1;

            # require(), not use(), YAML classes because YAML and YAML::Active
            # might conflict.
            my $test_def;
            if ($tests_yaml =~ /^use_yaml_active:\s*1/m) {
                note 'Loading with YAML::Active.pm';
                require YAML::Active;
                $test_def = YAML::Active::Load($tests_yaml);
            } else {
                require YAML;

                # Erik P. Ostlyngen writes:
                #
                # There seems to be a difference in the behaviour of YAML and
                # YAML::XS when it comes to wide characters. YAML::Load()
                # wants the string to be a perl wide character string whereas
                # YAML::XS::Load() wants a string of bytes which it tries to
                # utf-8 decode afterwards.
                #
                # This is a problem in Class::Scaffold::App::Test::YAMLDriven
                # because it uses both of the two YAML modules. So if we're
                # writing our tests with the use_yaml_active tag, we can
                # include utf-8 in the document. But if we instead use YAML
                # with the marshall classes, we cannot use utf-8 directly.
                #
                # I think it would be a good idea to support utf-8 encoding
                # both in yaml-active and yaml-marshall documents and in the
                # same way. This could easily be fixed with [decode_utf8()].
                $test_def = YAML::Load(decode_utf8($tests_yaml));

                # note explain $test_def;
            }
            $self->test_def($name => $test_def);
        }
    }
}

sub ordered_test_def_keys {
    my $self = shift;
    my @tests;
    if ($self->opt->{shuffle}) {
        note 'test order: shuffle';
        @tests = shuffle $self->test_def_keys;
    } elsif ($self->opt->{reverse}) {
        note 'test order: reverse';
        @tests = reverse sort $self->test_def_keys;
    } else {
        note 'test order: sort';