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