1# Perl module for parsing and generating the Subunit protocol 2# Copyright (C) 2008-2009 Jelmer Vernooij <jelmer@samba.org> 3# 4# This program is free software; you can redistribute it and/or modify 5# it under the terms of the GNU General Public License as published by 6# the Free Software Foundation; either version 3 of the License, or 7# (at your option) any later version. 8 9# This program is distributed in the hope that it will be useful, 10# but WITHOUT ANY WARRANTY; without even the implied warranty of 11# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12# GNU General Public License for more details. 13 14# You should have received a copy of the GNU General Public License 15# along with this program. If not, see <http://www.gnu.org/licenses/>. 16 17package Subunit; 18use POSIX; 19 20require Exporter; 21@ISA = qw(Exporter); 22@EXPORT_OK = qw(parse_results); 23 24use strict; 25 26sub parse_results($$$) 27{ 28 my ($msg_ops, $statistics, $fh) = @_; 29 my $expected_fail = 0; 30 my $unexpected_fail = 0; 31 my $unexpected_err = 0; 32 my $open_tests = []; 33 34 while(<$fh>) { 35 if (/^test: (.+)\n/) { 36 $msg_ops->control_msg($_); 37 $msg_ops->start_test($1); 38 push (@$open_tests, $1); 39 } elsif (/^time: (\d+)-(\d+)-(\d+) (\d+):(\d+):(\d+)\n/) { 40 $msg_ops->report_time(mktime($6, $5, $4, $3, $2-1, $1-1900)); 41 } elsif (/^(success|successful|failure|fail|skip|knownfail|error|xfail|skip-testsuite|testsuite-failure|testsuite-xfail|testsuite-success|testsuite-error): (.*?)( \[)?([ \t]*)\n/) { 42 $msg_ops->control_msg($_); 43 my $result = $1; 44 my $testname = $2; 45 my $reason = undef; 46 if ($3) { 47 $reason = ""; 48 # reason may be specified in next lines 49 my $terminated = 0; 50 while(<$fh>) { 51 $msg_ops->control_msg($_); 52 if ($_ eq "]\n") { $terminated = 1; last; } else { $reason .= $_; } 53 } 54 55 unless ($terminated) { 56 $statistics->{TESTS_ERROR}++; 57 $msg_ops->end_test($testname, "error", 1, 58 "reason ($result) interrupted"); 59 return 1; 60 } 61 } 62 if ($result eq "success" or $result eq "successful") { 63 pop(@$open_tests); #FIXME: Check that popped value == $testname 64 $statistics->{TESTS_EXPECTED_OK}++; 65 $msg_ops->end_test($testname, "success", 0, $reason); 66 } elsif ($result eq "xfail" or $result eq "knownfail") { 67 pop(@$open_tests); #FIXME: Check that popped value == $testname 68 $statistics->{TESTS_EXPECTED_FAIL}++; 69 $msg_ops->end_test($testname, "xfail", 0, $reason); 70 $expected_fail++; 71 } elsif ($result eq "failure" or $result eq "fail") { 72 pop(@$open_tests); #FIXME: Check that popped value == $testname 73 $statistics->{TESTS_UNEXPECTED_FAIL}++; 74 $msg_ops->end_test($testname, "failure", 1, $reason); 75 $unexpected_fail++; 76 } elsif ($result eq "skip") { 77 $statistics->{TESTS_SKIP}++; 78 # Allow tests to be skipped without prior announcement of test 79 my $last = pop(@$open_tests); 80 if (defined($last) and $last ne $testname) { 81 push (@$open_tests, $testname); 82 } 83 $msg_ops->end_test($testname, "skip", 0, $reason); 84 } elsif ($result eq "error") { 85 $statistics->{TESTS_ERROR}++; 86 pop(@$open_tests); #FIXME: Check that popped value == $testname 87 $msg_ops->end_test($testname, "error", 1, $reason); 88 $unexpected_err++; 89 } elsif ($result eq "skip-testsuite") { 90 $msg_ops->skip_testsuite($testname); 91 } elsif ($result eq "testsuite-success") { 92 $msg_ops->end_testsuite($testname, "success", $reason); 93 } elsif ($result eq "testsuite-failure") { 94 $msg_ops->end_testsuite($testname, "failure", $reason); 95 } elsif ($result eq "testsuite-xfail") { 96 $msg_ops->end_testsuite($testname, "xfail", $reason); 97 } elsif ($result eq "testsuite-error") { 98 $msg_ops->end_testsuite($testname, "error", $reason); 99 } 100 } elsif (/^testsuite: (.*)\n/) { 101 $msg_ops->start_testsuite($1); 102 } elsif (/^testsuite-count: (\d+)\n/) { 103 $msg_ops->testsuite_count($1); 104 } else { 105 $msg_ops->output_msg($_); 106 } 107 } 108 109 while ($#$open_tests+1 > 0) { 110 $msg_ops->end_test(pop(@$open_tests), "error", 1, 111 "was started but never finished!"); 112 $statistics->{TESTS_ERROR}++; 113 $unexpected_err++; 114 } 115 116 return 1 if $unexpected_err > 0; 117 return 1 if $unexpected_fail > 0; 118 return 0; 119} 120 121sub start_test($) 122{ 123 my ($testname) = @_; 124 print "test: $testname\n"; 125} 126 127sub end_test($$;$) 128{ 129 my $name = shift; 130 my $result = shift; 131 my $reason = shift; 132 if ($reason) { 133 print "$result: $name [\n"; 134 print "$reason"; 135 print "]\n"; 136 } else { 137 print "$result: $name\n"; 138 } 139} 140 141sub skip_test($;$) 142{ 143 my $name = shift; 144 my $reason = shift; 145 end_test($name, "skip", $reason); 146} 147 148sub fail_test($;$) 149{ 150 my $name = shift; 151 my $reason = shift; 152 end_test($name, "fail", $reason); 153} 154 155sub success_test($;$) 156{ 157 my $name = shift; 158 my $reason = shift; 159 end_test($name, "success", $reason); 160} 161 162sub xfail_test($;$) 163{ 164 my $name = shift; 165 my $reason = shift; 166 end_test($name, "xfail", $reason); 167} 168 169sub report_time($) 170{ 171 my ($time) = @_; 172 my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime($time); 173 printf "time: %04d-%02d-%02d %02d:%02d:%02d\n", $year+1900, $mon+1, $mday, $hour, $min, $sec; 174} 175 176# The following are Samba extensions: 177 178sub start_testsuite($) 179{ 180 my ($name) = @_; 181 print "testsuite: $name\n"; 182} 183 184sub skip_testsuite($;$) 185{ 186 my ($name, $reason) = @_; 187 if ($reason) { 188 print "skip-testsuite: $name [\n$reason\n]\n"; 189 } else { 190 print "skip-testsuite: $name\n"; 191 } 192} 193 194sub end_testsuite($$;$) 195{ 196 my $name = shift; 197 my $result = shift; 198 my $reason = shift; 199 if ($reason) { 200 print "testsuite-$result: $name [\n"; 201 print "$reason\n"; 202 print "]\n"; 203 } else { 204 print "testsuite-$result: $name\n"; 205 } 206} 207 208sub testsuite_count($) 209{ 210 my ($count) = @_; 211 print "testsuite-count: $count\n"; 212} 213 2141; 215