subunit.pm: Fold Subunit::Filter into Subunit, trim further.
[samba.git] / selftest / Subunit.pm
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
17 package Subunit;
18 use POSIX;
19
20 require Exporter;
21 @ISA = qw(Exporter);
22 @EXPORT_OK = qw(filter_add_prefix);
23
24 use strict;
25
26 sub filter_add_prefix($$)
27 {
28         my ($prefix, $fh) = @_;
29
30         while(<$fh>) {
31                 if (/^test: (.+)\n/) {
32                         Subunit::start_test($prefix.$1);
33                 } elsif (/^(success|successful|failure|fail|skip|knownfail|error|xfail): (.*?)( \[)?([ \t]*)( multipart)?\n/) {
34                         my $result = $1;
35                         my $testname = $prefix.$2;
36                         my $reason = undef;
37                         if ($3) {
38                                 $reason = "";
39                                 # reason may be specified in next lines
40                                 my $terminated = 0;
41                                 while(<$fh>) {
42                                         if ($_ eq "]\n") { $terminated = 1; last; } else { $reason .= $_; }
43                                 }
44
45                                 unless ($terminated) {
46                                         print $reason;
47                                         $reason = "reason ($result) interrupted";
48                                         $result = "error";
49                                 }
50                         }
51                         Subunit::end_test($testname, $result, $reason);
52                 } else {
53                         print $_;
54                 }
55         }
56 }
57
58 sub start_test($)
59 {
60         my ($testname) = @_;
61         print "test: $testname\n";
62 }
63
64 sub end_test($$;$)
65 {
66         my $name = shift;
67         my $result = shift;
68         my $reason = shift;
69         if ($reason) {
70                 print "$result: $name [\n";
71                 print $reason;
72                 if (substr($reason, -1, 1) ne "\n") { print "\n"; }
73                 print "]\n";
74         } else {
75                 print "$result: $name\n";
76         }
77 }
78
79 sub report_time($)
80 {
81         my ($time) = @_;
82         my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime($time);
83         $sec = ($time - int($time) + $sec);
84         my $msg = sprintf("%f", $sec);
85         if (substr($msg, 1, 1) eq ".") {
86                 $msg = "0" . $msg;
87         }
88         printf "time: %04d-%02d-%02d %02d:%02d:%s\n", $year+1900, $mon+1, $mday, $hour, $min, $msg;
89 }
90
91 sub progress_pop()
92 {
93         print "progress: pop\n";
94 }
95
96 sub progress_push()
97 {
98         print "progress: push\n";
99 }
100
101 sub progress($;$)
102 {
103         my ($count, $whence) = @_;
104
105         unless(defined($whence)) {
106                 $whence = "";
107         }
108
109         print "progress: $whence$count\n";
110 }
111
112 # The following are Samba extensions:
113
114 sub start_testsuite($)
115 {
116         my ($name) = @_;
117         print "testsuite: $name\n";
118 }
119
120 sub skip_testsuite($;$)
121 {
122         my ($name, $reason) = @_;
123         if ($reason) {
124                 print "skip-testsuite: $name [\n$reason\n]\n";
125         } else {
126                 print "skip-testsuite: $name\n";
127         }
128 }
129
130 sub end_testsuite($$;$)
131 {
132         my $name = shift;
133         my $result = shift;
134         my $reason = shift;
135         if ($reason) {
136                 print "testsuite-$result: $name [\n";
137                 print "$reason\n";
138                 print "]\n";
139         } else {
140                 print "testsuite-$result: $name\n";
141         }
142 }
143
144 1;