123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112 |
- #!/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);
|