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