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 use Time::HiRes;
  20
  21 require Exporter;
  22 @ISA = qw(Exporter);
  23
  24 use strict;
  25 use warnings;
  26
  27 sub start_test($)
  28 {
  29         my ($testname) = @_;
  30         print "test: $testname\n";
  31 }
  32
  33 sub end_test($$;$)
  34 {
  35         my $name = shift;
  36         my $result = shift;
  37         my $reason = shift;
  38         if ($reason) {
  39                 print "$result: $name [\n";
  40                 print $reason;
  41                 if (substr($reason, -1, 1) ne "\n") { print "\n"; }
  42                 print "]\n";
  43         } else {
  44                 print "$result: $name\n";
  45         }
  46 }
  47
  48 sub report_time()
  49 {
  50         my ($time) = @_;
  51         $time = Time::HiRes::time() unless (defined($time));
  52         my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = gmtime($time);
  53         $sec = ($time - int($time) + $sec);
  54         my $msg = sprintf("%f", $sec);
  55         if (substr($msg, 1, 1) eq ".") {
  56                 $msg = "0" . $msg;
  57         }
  58         printf "time: %04d-%02d-%02d %02d:%02d:%sZ\n", $year+1900, $mon+1, $mday, $hour, $min, $msg;
  59 }
  60
  61 sub progress_pop()
  62 {
  63         print "progress: pop\n";
  64 }
  65
  66 sub progress_push()
  67 {
  68         print "progress: push\n";
  69 }
  70
  71 sub progress($;$)
  72 {
  73         my ($count, $whence) = @_;
  74
  75         unless(defined($whence)) {
  76                 $whence = "";
  77         }
  78
  79         print "progress: $whence$count\n";
  80 }
  81
  82 # The following are Samba extensions:
  83
  84 sub start_testsuite($)
  85 {
  86         my ($name) = @_;
  87         print "testsuite: $name\n";
  88 }
  89
  90 sub skip_testsuite($;$)
  91 {
  92         my ($name, $reason) = @_;
  93         if ($reason) {
  94                 print "skip-testsuite: $name [\n$reason\n]\n";
  95         } else {
  96                 print "skip-testsuite: $name\n";
  97         }
  98 }
  99
 100 sub end_testsuite($$;$)
 101 {
 102         my $name = shift;
 103         my $result = shift;
 104         my $reason = shift;
 105         if ($reason) {
 106                 print "testsuite-$result: $name [\n";
 107                 print "$reason\n";
 108                 print "]\n";
 109         } else {
 110                 print "testsuite-$result: $name\n";
 111         }
 112 }
 113
 114 1;