X-Git-Url: https://git.saurik.com/apple/objc4.git/blobdiff_plain/7c0e6487d7b67b6bf6c632300ee4b74e8950b051..7af964d1562d70f51a8e9aca24215ac3d83d0624:/test/errcheck.pl

diff --git a/test/errcheck.pl b/test/errcheck.pl
new file mode 100644
index 0000000..dd49a18
--- /dev/null
+++ b/test/errcheck.pl
@@ -0,0 +1,116 @@
+#!/usr/bin/perl
+use strict;
+
+# errcheck.pl
+# Check test output for errors.
+# usage: test.out | errcheck.pl test [stderr-file]
+
+my $testname = shift || die;
+my $errfile = shift || "$testname.expected-stderr";
+
+my @input;
+my @original_input;
+while (my $line = <>) {
+    chomp $line;
+    push @input, $line;
+    push @original_input, $line;
+}
+
+# Run result-checking passes, reducing @input each time
+my $xit = 0;
+my $bad = "";
+$bad |= filter_valgrind() if ($ENV{VALGRIND});
+$bad = filter_expected() if ($bad eq ""  &&  -e $errfile);
+$bad = filter_bad()  if ($bad eq "");
+
+# OK line should be the only one left
+$bad = "(output not 'OK: $testname')" if ($bad eq ""  &&  (scalar(@input) != 1  ||  $input[0] !~ /^OK: $testname/));
+
+if ($bad ne "") {
+    my $red = "\e[41;37m";
+    my $def = "\e[0m";
+    $xit = 1;
+    print "${red}BAD: /// test '$testname' \\\\\\$def\n";
+    for my $line (@original_input) {
+	print "$red $def$line\n";
+    }
+    print "${red}BAD: \\\\\\ test '$testname' ///$def\n";
+    print "${red}FAIL: ## $testname: $bad$def\n";
+} else {
+    print "PASS: $testname\n";
+}
+
+exit $xit;
+
+sub filter_expected
+{
+    my $bad = "";
+
+    open(my $checkfile, $errfile) 
+	|| die "can't find $errfile\n";
+    my $check = join('', <$checkfile>);
+    close($checkfile);
+
+    my $input = join("\n", @input) . "\n";
+    if ($input !~ /^$check$/s) {
+	$bad = "(didn't match $errfile)";
+	@input = "BAD: $testname";
+    } else {
+	@input = "OK: $testname";  # pacify later filter
+    }
+
+    return $bad;
+}
+
+sub filter_bad
+{
+    my $bad = "";
+
+    my @new_input;
+    for my $line (@input) {
+	chomp $line;
+	if ($line =~ /^BAD: (.*)/) {
+	    $bad = "(failed)";
+	} else {
+	    push @new_input, $line;
+	}
+    }
+    @input = @new_input;
+    return $bad;
+}
+
+sub filter_valgrind
+{
+    my $errors = 0;
+    my $leaks = 0;
+
+    my @new_input;
+    for my $line (@input) {
+	if ($line =~ /^Approx: do_origins_Dirty\([RW]\): missed \d bytes$/) {
+	    # --track-origins warning (harmless)
+	    next;
+	}
+	if ($line !~ /^^\.*==\d+==/) {
+	    # not valgrind output
+	    push @new_input, $line;
+	    next;
+	}
+
+	my ($errcount) = ($line =~ /==\d+== ERROR SUMMARY: (\d+) errors/);
+	if (defined $errcount  &&  $errcount > 0) {
+	    $errors = 1;
+	}
+
+	(my $leakcount) = ($line =~ /==\d+==\s+(?:definitely|possibly) lost:\s+([0-9,]+)/);
+	if (defined $leakcount  &&  $leakcount > 0) {
+	    $leaks = 1;
+	}
+    }
+
+    @input = @new_input;
+
+    my $bad = "";
+    $bad .= "(valgrind errors)" if ($errors);
+    $bad .= "(valgrind leaks)" if ($leaks);
+    return $bad;
+}