selftest/Subunit/Filter.pm

   1 #!/usr/bin/perl
   2 # Filter a subunit stream
   3 # Copyright (C) Jelmer Vernooij <jelmer@samba.org>
   4 # Published under the GNU GPL, v3 or later
   5
   6 package Subunit::Filter;
   7
   8 use strict;
   9
  10 sub read_test_regexes($)
  11 {
  12         my ($name) = @_;
  13         my @ret = ();
  14         open(LF, "<$name") or die("unable to read $name: $!");
  15         while (<LF>) {
  16                 chomp;
  17                 next if (/^#/);
  18                 next if (/^$/);
  19                 if (/^(.*?)([ \t]+)\#([\t ]*)(.*?)$/) {
  20                         push (@ret, [$1, $4]);
  21                 } else {
  22                         s/^(.*?)([ \t]+)\#([\t ]*)(.*?)$//;
  23                         push (@ret, [$_, undef]);
  24                 }
  25         }
  26         close(LF);
  27         return @ret;
  28 }
  29
  30 sub find_in_list($$)
  31 {
  32         my ($list, $fullname) = @_;
  33
  34         foreach (@$list) {
  35                 if ($fullname =~ /$$_[0]/) {
  36                          return ($$_[1]) if ($$_[1]);
  37                          return "";
  38                 }
  39         }
  40
  41         return undef;
  42 }
  43
  44 sub control_msg()
  45 {
  46         # We regenerate control messages, so ignore this
  47 }
  48
  49 sub report_time($$)
  50 {
  51         my ($self, $time) = @_;
  52         Subunit::report_time($time);
  53 }
  54
  55 sub output_msg($$)
  56 {
  57         my ($self, $msg) = @_;
  58         unless(defined($self->{output})) {
  59                 print $msg;
  60         } else {
  61                 $self->{output}.=$msg;
  62         }
  63 }
  64
  65 sub start_test($$)
  66 {
  67         my ($self, $testname) = @_;
  68
  69         if (defined($self->{prefix})) {
  70                 $testname = $self->{prefix}.$testname;
  71         }
  72
  73         if ($self->{strip_ok_output}) {
  74                 $self->{output} = "";
  75         }
  76
  77         Subunit::start_test($testname);
  78 }
  79
  80 sub end_test($$$$$)
  81 {
  82         my ($self, $testname, $result, $unexpected, $reason) = @_;
  83
  84         if (defined($self->{prefix})) {
  85                 $testname = $self->{prefix}.$testname;
  86         }
  87
  88         if (($result eq "fail" or $result eq "failure") and not $unexpected) {
  89                 $result = "xfail";
  90                 $self->{xfail_added}++;
  91                 $self->{total_xfail}++;
  92         }
  93         my $xfail_reason = find_in_list($self->{expected_failures}, $testname);
  94         if (defined($xfail_reason) and ($result eq "fail" or $result eq "failure")) {
  95                 $result = "xfail";
  96                 $self->{xfail_added}++;
  97                 $self->{total_xfail}++;
  98                 $reason .= $xfail_reason;
  99         }
 100
 101         if ($result eq "fail" or $result eq "failure") {
 102                 $self->{fail_added}++;
 103                 $self->{total_fail}++;
 104         }
 105
 106         if ($result eq "error") {
 107                 $self->{error_added}++;
 108                 $self->{total_error}++;
 109         }
 110
 111         if ($self->{strip_ok_output}) {
 112                 unless ($result eq "success" or $result eq "xfail" or $result eq "skip") {
 113                         print $self->{output}
 114                 }
 115         }
 116         $self->{output} = undef;
 117
 118         Subunit::end_test($testname, $result, $reason);
 119 }
 120
 121 sub skip_testsuite($;$)
 122 {
 123         my ($self, $name, $reason) = @_;
 124         Subunit::skip_testsuite($name, $reason);
 125 }
 126
 127 sub start_testsuite($;$)
 128 {
 129         my ($self, $name) = @_;
 130         Subunit::start_testsuite($name);
 131
 132         $self->{error_added} = 0;
 133         $self->{fail_added} = 0;
 134         $self->{xfail_added} = 0;
 135 }
 136
 137 sub end_testsuite($$;$)
 138 {
 139         my ($self, $name, $result, $reason) = @_;
 140         my $xfail = 0;
 141
 142         $xfail = 1 if ($self->{xfail_added} > 0);
 143         $xfail = 0 if ($self->{fail_added} > 0);
 144         $xfail = 0 if ($self->{error_added} > 0);
 145
 146         if ($xfail and ($result eq "fail" or $result eq "failure")) {
 147                 $result = "xfail";
 148         }
 149
 150         if ($self->{fail_added} > 0 and $result ne "failure") {
 151                 $result = "failure";
 152                 $reason = "Subunit/Filer Reason" unless defined($reason);
 153                 $reason .= "\n failures[$self->{fail_added}]";
 154         }
 155
 156         if ($self->{error_added} > 0 and $result ne "error") {
 157                 $result = "error";
 158                 $reason = "Subunit/Filer Reason" unless defined($reason);
 159                 $reason .= "\n errors[$self->{error_added}]";
 160         }
 161
 162         Subunit::end_testsuite($name, $result, $reason);
 163 }
 164
 165 sub testsuite_count($$)
 166 {
 167         my ($self, $count) = @_;
 168         Subunit::testsuite_count($count);
 169 }
 170
 171 sub new {
 172         my ($class, $prefix, $expected_failures, $strip_ok_output) = @_;
 173
 174         my $self = {
 175                 prefix => $prefix,
 176                 expected_failures => $expected_failures,
 177                 strip_ok_output => $strip_ok_output,
 178                 xfail_added => 0,
 179                 total_xfail => 0,
 180                 total_error => 0,
 181                 total_fail => 0
 182         };
 183         bless($self, $class);
 184 }
 185
 186 1;