minions/bin/autotest.pl

#!/usr/bin/perl -w

## Author: Alois Mahdal at zxcvb cz
# my private testing helper script

# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.

# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.


use v5.10;
use warnings;
use File::Spec;
use Getopt::Long;

my $PLATFORM    = (-d "c:\\windows" ? 'windows' : 'unix' );
my $DELAY       = 5;
my $COLORS      = { windows => { ok => 'color 0a', nok => 'color 0c' } };
my $DUMPS       = "dumps";
my $REPEAT      = 1;
my $TESTS       = "t";

my $opts = GetOptions(
    "delay=i"   => \$DELAY,
    "tests=s"   => \$TESTS,
    "dumps=s"   => \$DUMPS,
    "repeat!"   => \$REPEAT,
);


sub clear {
    if ($PLATFORM eq 'windows') {
        system "cls";
    } elsif ($PLATFORM eq 'unix') {
        system "clear";
    }
}

sub color {
    $mood = shift;
    $cmd = $COLORS->{$PLATFORM}->{$mood};
    system ($cmd) if $cmd;
}

sub cat {
    my $name = File::Spec->splitpath( shift );
    printf "$name:\n";
    if (open my $fh,  "<", $_) {
        my @lines = <$fh>;
        print @lines, "\n";
        close $fh or die "cannot close $_"
    }
    else {
        warn "cannot open $_";
        next STDERR;
    }
}

sub run_tests {
    my $ret = 0;
    printf "===== STDOUT =====\n";
    foreach (@_) {
        my $name = File::Spec->splitpath( $_ );
        say "$name:";
        $cmd = sprintf 'perl %s 2>%s',
                        File::Spec->catdir( $TESTS, $name ),
                        File::Spec->catdir( $DUMPS, $name . '.err' );
        system($cmd);
        $ret = $? >> 8;
        if ($ret) {
            print "last test failed with exit code $ret!\n";
            return;
        }
    }
    return 1;
}

sub freakout {
    my $ret = shift;
    color "nok";
    my @paths = glob "$DUMPS/*.err";
    printf "\n===== STDERR =====\n";
    STDERR: foreach (@paths) {
        cat $_ and unlink $_ or warn "could not print $_";
    }
}

mkdir $DUMPS unless -d $DUMPS;

do {
    my @paths = glob "$TESTS/*.t";
    &clear;
    color "ok";
    my $ok = &run_tests(@paths);
    if ($ok) {
        say "------------------";
        say "All tests finished.";
    } else {
        &freakout();
    }
    sleep $DELAY if $REPEAT;
} while ($REPEAT);