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         }
  92         my $xfail_reason = find_in_list($self->{expected_failures}, $testname);
  93         if (defined($xfail_reason) and ($result eq "fail" or $result eq "failure")) {
  94                 $result = "xfail";
  95                 $self->{xfail_added}++;
  96                 $reason .= $xfail_reason;
  97         }
  98
  99         if ($result eq "fail" or $result eq "failure") {
 100                 $self->{fail_added}++;
 101         }
 102
 103         if ($self->{strip_ok_output}) {
 104                 unless ($result eq "success" or $result eq "xfail" or $result eq "skip") {
 105                         print $self->{output}
 106                 }
 107         }
 108         $self->{output} = undef;
 109
 110         Subunit::end_test($testname, $result, $reason);
 111 }
 112
 113 sub skip_testsuite($;$)
 114 {
 115         my ($self, $name, $reason) = @_;
 116         Subunit::skip_testsuite($name, $reason);
 117 }
 118
 119 sub start_testsuite($;$)
 120 {
 121         my ($self, $name) = @_;
 122         Subunit::start_testsuite($name);
 123         $self->{fail_added} = 0;
 124         $self->{xfail_added} = 0;
 125 }
 126
 127 sub end_testsuite($$;$)
 128 {
 129         my ($self, $name, $result, $reason) = @_;
 130         if ($self->{fail_added} == 0 and $self->{xfail_added} and
 131             ($result eq "fail" or $result eq "failure")) {
 132                 $result = "xfail";
 133         }
 134
 135         Subunit::end_testsuite($name, $result, $reason);
 136 }
 137
 138 sub testsuite_count($$)
 139 {
 140         my ($self, $count) = @_;
 141         Subunit::testsuite_count($count);
 142 }
 143
 144 sub new {
 145         my ($class, $prefix, $expected_failures, $strip_ok_output) = @_;
 146
 147         my $self = {
 148                 prefix => $prefix,
 149                 expected_failures => $expected_failures,
 150                 strip_ok_output => $strip_ok_output,
 151                 xfail_added => 0,
 152         };
 153         bless($self, $class);
 154 }
 155
 156 1;