1 files changed, 167 insertions, 0 deletions
diff --git a/mysql-test/lib/mtr_results.pm b/mysql-test/lib/mtr_results.pm
new file mode 100644
index 00000000..9438b936
--- /dev/null
+++ b/mysql-test/lib/mtr_results.pm
@@ -0,0 +1,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;