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