The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

use YAML::Syck;
use Data::Dumper;
use Getopt::Long;

our $opt_tag = undef;
our $verbose;
GetOptions(
    'tag=s' => $opt_tag,
    'verbose' => $verbose
);

our $testcase_string;
{
    local $/ = undef;
    $testcase_string = <>;
}

my @testcases;
eval {
    @testcases = Load($testcase_string);
};
if ($@ and $testcase_string =~ /\{\{\{/) {
    die "    This test case looks like a legacy one; I don't understand how to parse it\n";
} elsif ($@) {
    die "    There was an error parsing this test case: $@\n";
}

foreach my $tc (@testcases) {
    check_testcase($tc);
}

sub check_testcase {
    my ($tc) = @_;
    next if exists $tc->{TESTLINK_ID};
    die "    A test case was found with no name\n" unless exists($tc->{NAME});

    if ($opt_tag) {
        if (ref($tc->{TAGS}) ne 'ARRAY' or ! grep /$opt_tag/, @{ $tc->{TAGS} }) {
            print "    Skipping testcase \"$tc->{NAME}\" since it doesn't have the tag \"$opt_tag\"\n";
            return;
        }
    }

    print "    Checking testcase \"$tc->{NAME}\"\n";
    if (ref($tc->{INSTRUCTIONS}) ne 'ARRAY') {
        print "  ** This is not automated; skipping\n";
        return;
    }
    my @test_cases = @{ $tc->{INSTRUCTIONS} };
    while (my $test = shift @test_cases) {
        my ($name) = keys %$test;
        my ($value) = values %$test;
        if (ref($value) eq 'ARRAY') {
            unshift(@test_cases, @{ $value });
            next;
        }
        check_fixture($name, $value);
    }
    print "        Testcase looks okay!\n";
}

sub check_fixture {
    my ($name, @args) = @_;
    print "\t$name\n" if $verbose;
    # Magic happens here
}