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