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                 if (/^(.*?)([ \t]+)\#([\t ]*)(.*?)$/) {
  19                         push (@ret, [$1, $4]);
  20                 } else {
  21                         s/^(.*?)([ \t]+)\#([\t ]*)(.*?)$//;
  22                         push (@ret, [$_, undef]);
  23                 }
  24         }
  25         close(LF);
  26         return @ret;
  27 }
  28
  29 sub find_in_list($$)
  30 {
  31         my ($list, $fullname) = @_;
  32
  33         foreach (@$list) {
  34                 if ($fullname =~ /$$_[0]/) {
  35                          return ($$_[1]) if ($$_[1]);
  36                          return "";
  37                 }
  38         }
  39
  40         return undef;
  41 }
  42
  43 sub control_msg()
  44 {
  45         # We regenerate control messages, so ignore this
  46 }
  47
  48 sub report_time($$)
  49 {
  50         my ($self, $time) = @_;
  51         Subunit::report_time($time);
  52 }
  53
  54 sub output_msg($$)
  55 {
  56         my ($self, $msg) = @_;
  57         unless(defined($self->{output})) {
  58                 print $msg;
  59         } else {
  60                 $self->{output}.=$msg;
  61         }
  62 }
  63
  64 sub start_test($$)
  65 {
  66         my ($self, $testname) = @_;
  67
  68         if (defined($self->{prefix})) {
  69                 $testname = $self->{prefix}.$testname;
  70         }
  71
  72         if ($self->{strip_ok_output}) {
  73                 $self->{output} = "";
  74         }
  75
  76         Subunit::start_test($testname);
  77 }
  78
  79 sub end_test($$$$$)
  80 {
  81         my ($self, $testname, $result, $unexpected, $reason) = @_;
  82
  83         if (defined($self->{prefix})) {
  84                 $testname = $self->{prefix}.$testname;
  85         }
  86
  87         if (($result eq "fail" or $result eq "failure") and not $unexpected) {
  88                 $result = "xfail";
  89                 $self->{xfail_added}++;
  90         }
  91         my $xfail_reason = find_in_list($self->{expected_failures}, $testname);
  92         if (defined($xfail_reason) and ($result eq "fail" or $result eq "failure")) {
  93                 $result = "xfail";
  94                 $self->{xfail_added}++;
  95                 $reason .= $xfail_reason;
  96         }
  97
  98         if ($result eq "fail" or $result eq "failure") {
  99                 $self->{fail_added}++;
 100         }
 101
 102         if ($self->{strip_ok_output}) {
 103                 unless ($result eq "success" or $result eq "xfail" or $result eq "skip") {
 104                         print $self->{output}
 105                 }
 106         }
 107         $self->{output} = undef;
 108
 109         Subunit::end_test($testname, $result, $reason);
 110 }
 111
 112 sub skip_testsuite($;$)
 113 {
 114         my ($self, $name, $reason) = @_;
 115         Subunit::skip_testsuite($name, $reason);
 116 }
 117
 118 sub start_testsuite($;$)
 119 {
 120         my ($self, $name) = @_;
 121         Subunit::start_testsuite($name);
 122         $self->{fail_added} = 0;
 123         $self->{xfail_added} = 0;
 124 }
 125
 126 sub end_testsuite($$;$)
 127 {
 128         my ($self, $name, $result, $reason) = @_;
 129         if ($self->{fail_added} == 0 and $self->{xfail_added} and
 130             ($result eq "fail" or $result eq "failure")) {
 131                 $result = "xfail";
 132         }
 133
 134         Subunit::end_testsuite($name, $result, $reason);
 135 }
 136
 137 sub testsuite_count($$)
 138 {
 139         my ($self, $count) = @_;
 140         Subunit::testsuite_count($count);
 141 }
 142
 143 sub new {
 144         my ($class, $prefix, $expected_failures, $strip_ok_output) = @_;
 145
 146         my $self = {
 147                 prefix => $prefix,
 148                 expected_failures => $expected_failures,
 149                 strip_ok_output => $strip_ok_output,
 150                 xfail_added => 0,
 151         };
 152         bless($self, $class);
 153 }
 154
 155 1;