perl 5.000perl-5.000

[editor's note: this commit combines approximate 4 months of furious
releases of Andy Dougherty and Larry Wall - see pod/perlhist.pod for
details.  Andy notes that;
 
Alas neither my "Irwin AccuTrack" nor my DC 600A quarter-inch cartridge 
backup tapes from that era seem to be readable anymore.  I guess 13 years 
exceeds the shelf life for that backup technology :-(.
]

1 files changed, 80 insertions, 0 deletions

diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm
new file mode 100644
index 0000000000..8422f8e4bc
--- /dev/null
+++ b/lib/Test/Harness.pm
@@ -0,0 +1,80 @@
+package Test::Harness;
+
+use Exporter;
+use Benchmark;
+@ISA=(Exporter);
+@EXPORT= qw(&runtests &test_lib);
+@EXPORT_OK= qw($verbose $switches);
+
+$verbose = 0;
+$switches = "-w";
+
+sub runtests {
+    my(@tests) = @_;
+    local($|) = 1;
+    my($test,$te,$ok,$next,$max,$totmax, $files,$pct);
+    my $bad = 0;
+    my $good = 0;
+    my $total = @tests;
+    local($ENV{'PERL5LIB'}) = join(':', @INC); # pass -I flags to children
+
+    my $t_start = new Benchmark;
+    while ($test = shift(@tests)) {
+      $te = $test;
+      chop($te);
+      print "$te" . '.' x (20 - length($te));
+      my $fh = "RESULTS";
+      open($fh,"$^X $switches $test|") || (print "can't run. $!\n");
+      $ok = 0;
+      $next = 0;
+      while (<$fh>) {
+	  if( $verbose ){
+		  print $_;
+	  }
+          unless (/^#/) {
+              if (/^1\.\.([0-9]+)/) {
+                  $max = $1;
+                  $totmax += $max;
+                  $files += 1;
+                  $next = 1;
+                  $ok = 1;
+              } else {
+		  $next = $1, $ok = 0, last if /^not ok ([0-9]*)/;
+                  if (/^ok (.*)/ && $1 == $next) {
+                      $next = $next + 1;
+                  }
+              }
+          }
+      }
+      close($fh); # must close to reap child resource values
+      $next -= 1;
+      if ($ok && $next == $max) {
+          print "ok\n";
+          $good += 1;
+      } else {
+          $next += 1;
+          print "FAILED on test $next\n";
+          $bad += 1;
+          $_ = $test;
+      }
+    }
+    my $t_total = timediff(new Benchmark, $t_start);
+
+    if ($bad == 0) {
+      if ($ok) {
+          print "All tests successful.\n";
+      } else {
+          die "FAILED--no tests were run for some reason.\n";
+      }
+    } else {
+      $pct = sprintf("%.2f", $good / $total * 100);
+      if ($bad == 1) {
+          warn "Failed 1 test, $pct% okay.\n";
+      } else {
+          die "Failed $bad/$total tests, $pct% okay.\n";
+      }
+    }
+    printf("Files=%d,  Tests=%d, %s\n", $files,$totmax, timestr($t_total, 'nop'));
+}
+
+1;