123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112
  1. #!/usr/bin/perl -w
  2. ## Author: Alois Mahdal at vornet cz
  3. # my private testing helper script
  4. # This program is free software: you can redistribute it and/or modify
  5. # it under the terms of the GNU General Public License as published by
  6. # the Free Software Foundation, either version 3 of the License, or
  7. # (at your option) any later version.
  8. # This program is distributed in the hope that it will be useful,
  9. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. # GNU General Public License for more details.
  12. # You should have received a copy of the GNU General Public License
  13. # along with this program. If not, see <http://www.gnu.org/licenses/>.
  14. use v5.10;
  15. use warnings;
  16. use File::Spec;
  17. use Getopt::Long;
  18. my $PLATFORM = (-d "c:\\windows" ? 'windows' : 'unix' );
  19. my $DELAY = 5;
  20. my $COLORS = { windows => { ok => 'color 0a', nok => 'color 0c' } };
  21. my $DUMPS = "dumps";
  22. my $REPEAT = 1;
  23. my $TESTS = "t";
  24. my $opts = GetOptions(
  25. "delay=i" => \$DELAY,
  26. "tests=s" => \$TESTS,
  27. "dumps=s" => \$DUMPS,
  28. "repeat!" => \$REPEAT,
  29. );
  30. sub clear {
  31. if ($PLATFORM eq 'windows') {
  32. system "cls";
  33. } elsif ($PLATFORM eq 'unix') {
  34. system "clear";
  35. }
  36. }
  37. sub color {
  38. $mood = shift;
  39. $cmd = $COLORS->{$PLATFORM}->{$mood};
  40. system ($cmd) if $cmd;
  41. }
  42. sub cat {
  43. my $name = File::Spec->splitpath( shift );
  44. printf "$name:\n";
  45. if (open my $fh, "<", $_) {
  46. my @lines = <$fh>;
  47. print @lines, "\n";
  48. close $fh or die "cannot close $_"
  49. }
  50. else {
  51. warn "cannot open $_";
  52. next STDERR;
  53. }
  54. }
  55. sub run_tests {
  56. my $ret = 0;
  57. printf "===== STDOUT =====\n";
  58. foreach (@_) {
  59. my $name = File::Spec->splitpath( $_ );
  60. say "$name:";
  61. $cmd = sprintf 'perl %s 2>%s',
  62. File::Spec->catdir( $TESTS, $name ),
  63. File::Spec->catdir( $DUMPS, $name . '.err' );
  64. system($cmd);
  65. $ret = $? >> 8;
  66. if ($ret) {
  67. print "last test failed with exit code $ret!\n";
  68. return;
  69. }
  70. }
  71. return 1;
  72. }
  73. sub freakout {
  74. my $ret = shift;
  75. color "nok";
  76. my @paths = glob "$DUMPS/*.err";
  77. printf "\n===== STDERR =====\n";
  78. STDERR: foreach (@paths) {
  79. cat $_ and unlink $_ or warn "could not print $_";
  80. }
  81. }
  82. mkdir $DUMPS unless -d $DUMPS;
  83. do {
  84. my @paths = glob "$TESTS/*.t";
  85. &clear;
  86. color "ok";
  87. my $ok = &run_tests(@paths);
  88. if ($ok) {
  89. say "------------------";
  90. say "All tests finished.";
  91. } else {
  92. &freakout();
  93. }
  94. sleep $DELAY if $REPEAT;
  95. } while ($REPEAT);