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 ($result eq "error") {
 104                 $self->{error_added}++;
 105         }
 106
 107         if ($self->{strip_ok_output}) {
 108                 unless ($result eq "success" or $result eq "xfail" or $result eq "skip") {
 109                         print $self->{output}
 110                 }
 111         }
 112         $self->{output} = undef;
 113
 114         Subunit::end_test($testname, $result, $reason);
 115 }
 116
 117 sub skip_testsuite($;$)
 118 {
 119         my ($self, $name, $reason) = @_;
 120         Subunit::skip_testsuite($name, $reason);
 121 }
 122
 123 sub start_testsuite($;$)
 124 {
 125         my ($self, $name) = @_;
 126         Subunit::start_testsuite($name);
 127         $self->{error_added} = 0;
 128         $self->{fail_added} = 0;
 129         $self->{xfail_added} = 0;
 130 }
 131
 132 sub end_testsuite($$;$)
 133 {
 134         my ($self, $name, $result, $reason) = @_;
 135         my $xfail = 0;
 136
 137         $xfail = 1 if ($self->{xfail_added} > 0);
 138         $xfail = 0 if ($self->{fail_added} > 0);
 139         $xfail = 0 if ($self->{error_added} > 0);
 140
 141         if ($xfail and ($result eq "fail" or $result eq "failure")) {
 142                 $result = "xfail";
 143         }
 144
 145         if ($self->{fail_added} > 0 and $result ne "failure") {
 146                 $result = "failure";
 147                 $reason = "Subunit/Filer Reason" unless defined($reason);
 148                 $reason .= "\n failures[$self->{fail_added}]";
 149         }
 150
 151         if ($self->{error_added} > 0 and $result ne "error") {
 152                 $result = "error";
 153                 $reason = "Subunit/Filer Reason" unless defined($reason);
 154                 $reason .= "\n errors[$self->{error_added}]";
 155         }
 156
 157         Subunit::end_testsuite($name, $result, $reason);
 158 }
 159
 160 sub testsuite_count($$)
 161 {
 162         my ($self, $count) = @_;
 163         Subunit::testsuite_count($count);
 164 }
 165
 166 sub new {
 167         my ($class, $prefix, $expected_failures, $strip_ok_output) = @_;
 168
 169         my $self = {
 170                 prefix => $prefix,
 171                 expected_failures => $expected_failures,
 172                 strip_ok_output => $strip_ok_output,
 173                 xfail_added => 0,
 174         };
 175         bless($self, $class);
 176 }
 177
 178 1;