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