1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
|
# -*- cperl -*-
# Copyright (c) 2011, Oracle and/or its affiliates. All rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1335 USA
package mtr_results;
use strict;
use IO::Handle qw[ flush ];
use base qw(Exporter);
our @EXPORT= qw(resfile_init resfile_global resfile_new_test resfile_test_info
resfile_output resfile_output_file resfile_print
resfile_print_test resfile_to_test resfile_from_test );
my %curr_result; # Result for current test
my $curr_output; # Output for current test
my $do_resfile;
END {
close RESF if $do_resfile;
}
sub resfile_init($)
{
my $fname= shift;
open (RESF, " > $fname") or die ("Could not open result file $fname");
%curr_result= ();
$curr_output= "";
$do_resfile= 1;
}
# Strings need to be quoted if they start with white space or ",
# or if they contain newlines. Pass a reference to the string.
# If the string is quoted, " must be escaped, thus \ also must be escaped
sub quote_value($)
{
my $stref= shift;
for ($$stref) {
return unless /^[\s"]/ or /\n/;
s/\\/\\\\/g;
s/"/\\"/g;
$_= '"' . $_ . '"';
}
}
# Output global variable setting to result file.
sub resfile_global($$)
{
return unless $do_resfile;
my ($tag, $val) = @_;
$val= join (' ', @$val) if ref($val) eq 'ARRAY';
quote_value(\$val);
print RESF "$tag : $val\n";
}
# Prepare to add results for new test
sub resfile_new_test()
{
%curr_result= ();
$curr_output= "";
}
# Add (or change) one variable setting for current test
sub resfile_test_info($$)
{
my ($tag, $val) = @_;
return unless $do_resfile;
quote_value(\$val);
$curr_result{$tag} = $val;
}
# Add to output value for current test.
# Will be quoted if necessary, truncated if length over 5000.
sub resfile_output($)
{
return unless $do_resfile;
for (shift) {
my $len= length;
if ($len > 5000) {
my $trlen= $len - 5000;
$_= substr($_, 0, 5000) . "\n[TRUNCATED $trlen chars removed]\n";
}
s/\\/\\\\/g;
s/"/\\"/g;
$curr_output .= $_;
}
}
# Add to output, read from named file
sub resfile_output_file($)
{
resfile_output(::mtr_grab_file(shift)) if $do_resfile;
}
# Print text, and also append to current output if we're collecting results
sub resfile_print($)
{
my $txt= shift;
print($txt);
resfile_output($txt) if $do_resfile;
}
# Print results for current test, then reset
# (So calling a second time without having generated new results
# will have no effect)
sub resfile_print_test()
{
return unless %curr_result;
print RESF "{\n";
while (my ($t, $v) = each %curr_result) {
print RESF "$t : $v\n";
}
if ($curr_output) {
chomp($curr_output);
print RESF " output : " . $curr_output . "\"\n";
}
print RESF "}\n";
IO::Handle::flush(\*RESF);
resfile_new_test();
}
# Add current test results to test object (to send from worker)
sub resfile_to_test($)
{
return unless $do_resfile;
my $tinfo= shift;
my @res_array= %curr_result;
$tinfo->{'resfile'}= \@res_array;
$tinfo->{'output'}= $curr_output if $curr_output;
}
# Get test results (from worker) from test object
sub resfile_from_test($)
{
return unless $do_resfile;
my $tinfo= shift;
my $res_array= $tinfo->{'resfile'};
return unless $res_array;
%curr_result= @$res_array;
$curr_output= $tinfo->{'output'} if defined $tinfo->{'output'};
}
1;
|
