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 my $statistics = {
  44         SUITES_FAIL => 0,
  45
  46         TESTS_UNEXPECTED_OK => 0,
  47         TESTS_EXPECTED_OK => 0,
  48         TESTS_UNEXPECTED_FAIL => 0,
  49         TESTS_EXPECTED_FAIL => 0,
  50         TESTS_ERROR => 0,
  51         TESTS_SKIP => 0,
  52 };
  53
  54 sub control_msg()
  55 {
  56         # We regenerate control messages, so ignore this
  57 }
  58
  59 sub report_time($$)
  60 {
  61         my ($self, $time) = @_;
  62         Subunit::report_time($time);
  63 }
  64
  65 sub output_msg($$)
  66 {
  67         my ($self, $msg) = @_;
  68         print $msg;
  69 }
  70
  71 sub start_test($$)
  72 {
  73         my ($self, $testname) = @_;
  74
  75         if (defined($self->{prefix})) {
  76                 $testname = $self->{prefix}.$testname;
  77         }
  78
  79         Subunit::start_test($testname);
  80 }
  81
  82 sub end_test($$$$$)
  83 {
  84         my ($self, $testname, $result, $unexpected, $reason) = @_;
  85
  86         if (defined($self->{prefix})) {
  87                 $testname = $self->{prefix}.$testname;
  88         }
  89
  90         if (($result eq "fail" or $result eq "failure") and not $unexpected) { $result = "xfail"; }
  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                 $reason .= $xfail_reason;
  95         }
  96
  97         Subunit::end_test($testname, $result, $reason);
  98 }
  99
 100 sub skip_testsuite($;$)
 101 {
 102         Subunit::skip_testsuite(@_);
 103 }
 104
 105 sub start_testsuite($;$)
 106 {
 107         my ($self, $name) = @_;
 108         Subunit::start_testsuite($name);
 109 }
 110
 111 sub end_testsuite($$;$)
 112 {
 113         my ($self, $name, $result, $reason) = @_;
 114         Subunit::end_testsuite($name, $result, $reason);
 115 }
 116
 117 sub testsuite_count($$)
 118 {
 119         my ($self, $count) = @_;
 120         Subunit::testsuite_count($count);
 121 }
 122
 123 sub new {
 124         my ($class, $prefix, $expected_failures) = @_;
 125
 126         my $self = {
 127                 prefix => $prefix,
 128                 expected_failures => $expected_failures,
 129         };
 130         bless($self, $class);
 131 }
 132
 133 1;