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;