[44a1c2] | 1 | #!/usr/bin/perl |
---|
[b35b93] | 2 | |
---|
| 3 | ################################################################# |
---|
[b21d63] | 4 | # FILE: regress.cmd |
---|
[b35b93] | 5 | # PURPOSE: Script which runs regress test of Singular |
---|
| 6 | # CREATED: 2/16/98 |
---|
| 7 | # AUTHOR: obachman@mathematik.uni-kl.de |
---|
| 8 | |
---|
[1a300b9] | 9 | use Env; |
---|
[44a1c2] | 10 | |
---|
| 11 | # equivalent to command line options -CS, whihc is not supported any more |
---|
| 12 | use open ':std', ':utf8'; |
---|
| 13 | use open IO => ':bytes'; |
---|
[1a300b9] | 14 | |
---|
[b35b93] | 15 | ################################################################# |
---|
[b21d63] | 16 | # |
---|
[b35b93] | 17 | # usage |
---|
[b21d63] | 18 | # |
---|
[b35b93] | 19 | sub Usage |
---|
| 20 | { |
---|
| 21 | print <<_EOM_ |
---|
| 22 | Usage: |
---|
| 23 | regress.cmd -- regress test of Singular |
---|
[e960fdf] | 24 | [-s <Singular>] -- use <Singular> as executable to test |
---|
| 25 | [-h] -- print out help and exit |
---|
| 26 | [-k] -- keep all intermediate files |
---|
[6d01ca] | 27 | [-v num] -- set verbosity to num (used range 0..4, default: 2) |
---|
[e960fdf] | 28 | [-g] -- generate result (*.res.gz.uu) files, only |
---|
| 29 | [-r [crit%[val]]] -- report if status differences [of crit] > val (in %) |
---|
[31f293] | 30 | [-c regexp] -- when comparing results, version must match this regexp |
---|
[e960fdf] | 31 | [-e [crit%[val]]] -- throw error if status difference [of crit] > val (in %) |
---|
[31f293] | 32 | [-a [crit]] -- add status results [of crit] to result file |
---|
| 33 | [-m] -- add status result for current version to result file |
---|
[0b20296] | 34 | [-t] -- compute and call system("mtrack", 1) at the end, no diffs |
---|
[a7bb142] | 35 | [-A num] -- set timeout [in sec.] for executed Singular |
---|
[1a300b9] | 36 | [-C name] -- be TeamCity friendly, use "name" as a test-suite name |
---|
[0b20296] | 37 | [-tt max] -- compute and call system("mtrack", max) at the end |
---|
[6d01ca] | 38 | [-T] -- simply compute and determine timmings, no diffs |
---|
[e960fdf] | 39 | [file.lst] -- read tst files from file.lst |
---|
[b21d63] | 40 | [file.tst] -- test Singular script file.tst |
---|
[b35b93] | 41 | _EOM_ |
---|
| 42 | } |
---|
| 43 | |
---|
| 44 | ################################################################# |
---|
[b21d63] | 45 | # |
---|
[b35b93] | 46 | # used programs |
---|
| 47 | # |
---|
[55f154] | 48 | $sh="/bin/sh"; |
---|
[b35b93] | 49 | $diff = "diff"; |
---|
| 50 | $gunzip = "gunzip"; |
---|
| 51 | $gzip = "gzip"; |
---|
| 52 | $rm = "rm"; |
---|
[d5e119] | 53 | $mv = "mv"; |
---|
[b35b93] | 54 | $cp = "cp"; |
---|
[d5e119] | 55 | $tr = "tr"; |
---|
| 56 | $sed = "sed"; |
---|
| 57 | $cat = "cat"; |
---|
| 58 | $tee = "tee"; |
---|
[e960fdf] | 59 | $grep = "grep"; |
---|
[55f154] | 60 | |
---|
| 61 | sub mysystem |
---|
| 62 | { |
---|
| 63 | local($call) = $_[0]; |
---|
| 64 | local($exit_status); |
---|
| 65 | |
---|
| 66 | $call =~ s/"/\\"/g; |
---|
| 67 | $call = "$sh -c \"$call\""; |
---|
[6d01ca] | 68 | print "$call\n" if ($verbosity > 2); |
---|
[55f154] | 69 | return (system $call); |
---|
| 70 | } |
---|
| 71 | |
---|
[e960fdf] | 72 | sub mysystem_catch |
---|
| 73 | { |
---|
| 74 | local($call) = $_[0]; |
---|
| 75 | local($output) = ""; |
---|
| 76 | |
---|
| 77 | $call = "$call > catch_$$"; |
---|
[93e538] | 78 | mysystem($call); |
---|
[b21d63] | 79 | |
---|
[e960fdf] | 80 | open(CATCH_FILE, "<catch_$$"); |
---|
| 81 | while (<CATCH_FILE>) |
---|
| 82 | { |
---|
| 83 | $output = $output.$_; |
---|
| 84 | } |
---|
| 85 | close(CATCH_FILE); |
---|
[93e538] | 86 | mysystem("$rm -f catch_$$"); |
---|
[e960fdf] | 87 | return $output; |
---|
| 88 | } |
---|
| 89 | |
---|
[93e538] | 90 | $WINNT = 1 if (mysystem("uname -a | $grep CYGWIN > /dev/null 2>&1") == 0); |
---|
[e519027] | 91 | $uuencode = "uuencode"; |
---|
| 92 | $uudecode = "uudecode"; |
---|
[d5e119] | 93 | |
---|
[ff4a69] | 94 | # |
---|
| 95 | # flush stdout and stderr after every write |
---|
| 96 | # |
---|
| 97 | select(STDERR); |
---|
| 98 | $| = 1; |
---|
| 99 | select(STDOUT); |
---|
| 100 | $| = 1; |
---|
| 101 | |
---|
[b35b93] | 102 | ################################################################# |
---|
[b21d63] | 103 | # |
---|
[55f154] | 104 | # the default settings |
---|
| 105 | # |
---|
[56ae4f] | 106 | $singularOptions = "--ticks-per-sec=100 -teqsr12345678 --no-rc"; |
---|
[21a762] | 107 | # for testing under Windows, remove "e" option above and compile |
---|
| 108 | # res files on Linux, then copy to Windows and compare. Otherwise |
---|
| 109 | # you have problems with diff on Win. Just uncomment the next line: |
---|
[56ae4f] | 110 | # $singularOptions = "--ticks-per-sec=100 -tqsr12345678 --no-rc"; |
---|
[21a762] | 111 | |
---|
[55f154] | 112 | $keep = "no"; |
---|
[6d01ca] | 113 | $verbosity = 2; |
---|
[55f154] | 114 | $generate = "no"; |
---|
| 115 | $exit_code = 0; |
---|
| 116 | chop($curr_dir=`pwd`); |
---|
| 117 | # singular -- use the one in curr directory or the one found above |
---|
| 118 | $ext=".exe" if ($WINNT); |
---|
| 119 | $singular = "$curr_dir/Singular$ext"; |
---|
| 120 | if ( (! (-e $singular)) || (! (-x $singular))) |
---|
[b35b93] | 121 | { |
---|
[55f154] | 122 | $singular = $curr_dir."/../Singular$ext"; |
---|
[b35b93] | 123 | } |
---|
[a7bb142] | 124 | # timeout for Singular execution (in seconds!) |
---|
| 125 | $timeout = 0; |
---|
[55f154] | 126 | # sed scripts which are applied to res files before they are diff'ed |
---|
[1cb879] | 127 | $sed_scripts = "-e '/used time:/d' -e '/tst_ignore:/d' -e '/Id[:\$]/d' -e '/error occurred in/d' -e '/tst_status/d' -e'/init >>/d' -e 's/\\[[0-9]*:[0-9]*\\]//g'"; |
---|
[e960fdf] | 128 | # default value (in %) above which differences are reported on -r |
---|
[e2114af] | 129 | $report_val = 5; |
---|
[e960fdf] | 130 | # default value (in %) above which differences cause an error on -e |
---|
[e2114af] | 131 | $error_val = 5; |
---|
[374b14] | 132 | # default value in 1/100 seconds, above which time differences are reported |
---|
[a23d8e] | 133 | $mintime_val = 100; |
---|
[93e538] | 134 | $hostname = mysystem_catch("hostname"); |
---|
[e960fdf] | 135 | chop $hostname; |
---|
[55f154] | 136 | |
---|
[1a300b9] | 137 | # flag indicating whether to produce TeamCity output ("" - no): |
---|
| 138 | $teamcity = ""; |
---|
| 139 | # current argument: test file name? |
---|
| 140 | $test_file = ""; |
---|
| 141 | |
---|
[93e538] | 142 | # all previous test_file's: |
---|
| 143 | %test_files = (); |
---|
[1a300b9] | 144 | |
---|
| 145 | |
---|
| 146 | ################################################################# |
---|
| 147 | # |
---|
| 148 | # teamcity helpers: |
---|
| 149 | # |
---|
| 150 | sub myGetTCprop |
---|
| 151 | { |
---|
| 152 | local($prop) = $_[0]; |
---|
[93e538] | 153 | return( mysystem_catch("cat \"\$TEAMCITY_BUILD_PROPERTIES_FILE\"|grep \"$prop=\"|sed \"s/$prop=//\"") ); |
---|
[1a300b9] | 154 | } |
---|
| 155 | |
---|
| 156 | sub tc_filter |
---|
| 157 | { |
---|
| 158 | local($t) = $_[0]; |
---|
| 159 | |
---|
| 160 | $t =~ s/\|/|\|/g; |
---|
| 161 | |
---|
| 162 | $t =~ s/\n/|n/g; |
---|
| 163 | $t =~ s/\r/|r/g; |
---|
| 164 | |
---|
| 165 | $t =~ s/\u0085/|x/g; |
---|
| 166 | $t =~ s/\u2028/|l/g; |
---|
| 167 | $t =~ s/\u2029/|p/g; |
---|
| 168 | |
---|
| 169 | ## \x{263A} |
---|
| 170 | |
---|
| 171 | $t =~ s/\'/|\'/g; |
---|
| 172 | $t =~ s/\[/|\[/g; |
---|
| 173 | $t =~ s/\]/|\]/g; |
---|
| 174 | return ($t); |
---|
| 175 | } |
---|
| 176 | sub putTCmsg |
---|
| 177 | { |
---|
| 178 | if( length($teamcity) > 0 ) |
---|
| 179 | { |
---|
| 180 | local($message) = $_[0]; |
---|
| 181 | local($text) = $_[1]; |
---|
| 182 | |
---|
| 183 | print( "\n##teamcity[$message $text]\n" ); |
---|
| 184 | } |
---|
| 185 | } |
---|
| 186 | sub putTCmsgV |
---|
| 187 | { |
---|
| 188 | local($message) = $_[0]; |
---|
| 189 | local($unquotedValue) = tc_filter($_[1]); |
---|
| 190 | |
---|
| 191 | putTCmsg( $message, "\'$unquotedValue\'"); |
---|
| 192 | } |
---|
| 193 | sub putTCmsgNV |
---|
| 194 | { |
---|
| 195 | local($m) = $_[0]; |
---|
| 196 | local($p) = $_[1]; |
---|
| 197 | local($v) = tc_filter($_[2]); |
---|
| 198 | putTCmsg( $m, "$p=\'$v\'" ); |
---|
| 199 | } |
---|
| 200 | sub putTCmsgNV2 |
---|
| 201 | { |
---|
| 202 | local($m) = $_[0]; |
---|
| 203 | local($p) = $_[1]; |
---|
| 204 | local($v) = tc_filter($_[2]); |
---|
| 205 | local($pp) = $_[3]; |
---|
| 206 | local($vv) = tc_filter($_[4]); |
---|
| 207 | putTCmsg( $m, "$p='$v' $pp='$vv'" ); |
---|
| 208 | } |
---|
| 209 | |
---|
| 210 | ################################################################# |
---|
| 211 | # |
---|
| 212 | # teamcity routines: |
---|
| 213 | # |
---|
| 214 | sub blockOpened |
---|
| 215 | { |
---|
| 216 | local($v) = $_[0]; |
---|
| 217 | putTCmsgNV( "blockOpened", "name", $v); |
---|
| 218 | } |
---|
| 219 | sub blockClosed |
---|
| 220 | { |
---|
| 221 | local($v) = $_[0]; |
---|
| 222 | putTCmsgNV( "blockClosed", "name", $v); |
---|
| 223 | } |
---|
| 224 | sub tcError |
---|
| 225 | { |
---|
[ebb444] | 226 | local($text) = tc_filter($_[0]); |
---|
| 227 | local($details) = tc_filter($_[1]); |
---|
| 228 | local($status) = tc_filter($_[2]); |
---|
[1a300b9] | 229 | # The status attribute may take following values: |
---|
| 230 | # NORMAL, WARNING, FAILURE, ERROR. |
---|
| 231 | # The default value is NORMAL. |
---|
| 232 | # The errorDetails attribute is used only if status is ERROR, in other cases it is ignored. |
---|
| 233 | # This message fails the build in case its status is ERROR and "Fail build if an error message is logged by build runner" checkbox is checked on build configuration general settings page. |
---|
| 234 | |
---|
| 235 | ##teamcity[message text='<message text>' errorDetails='<error details>' status='<status value>'] |
---|
[ebb444] | 236 | putTCmsg( "message", "text=\'$text\' errorDetails=\'$details\' status=\'$status\'"); |
---|
| 237 | } |
---|
| 238 | |
---|
| 239 | sub tcFailure |
---|
| 240 | { |
---|
| 241 | local($text) = tc_filter($_[0]); |
---|
| 242 | local($details) = tc_filter($_[1]); |
---|
| 243 | tcError( $text, $details, "FAILURE" ); |
---|
| 244 | } |
---|
| 245 | |
---|
| 246 | sub tcLog |
---|
| 247 | { |
---|
| 248 | local($text) = $_[0]; |
---|
| 249 | putTCmsgNV2( "message", "text", $text, "status", "NORMAL"); |
---|
| 250 | } |
---|
| 251 | sub tcWarn |
---|
| 252 | { |
---|
| 253 | local($text) = $_[0]; |
---|
| 254 | putTCmsgNV2( "message", "text", $text, "status", "WARNING"); |
---|
[1a300b9] | 255 | } |
---|
| 256 | |
---|
| 257 | sub testSuiteStarted |
---|
| 258 | { |
---|
| 259 | local($v) = $_[0]; |
---|
| 260 | putTCmsgNV( "testSuiteStarted", "name", $v); |
---|
| 261 | } |
---|
| 262 | sub testSuiteFinished |
---|
| 263 | { |
---|
| 264 | local($v) = $_[0]; |
---|
| 265 | putTCmsgNV( "testSuiteFinished", "name", $v); |
---|
| 266 | } |
---|
[ebb444] | 267 | |
---|
| 268 | $failed = 0; |
---|
| 269 | |
---|
[e197f5] | 270 | sub testNameRemoveLeadingUnderscore |
---|
| 271 | { |
---|
| 272 | # make NN/_abs.tst - > NN/abs.tst |
---|
| 273 | local($t) = $_[0]; |
---|
| 274 | $t =~ s/^_([a-z0-9][^\/]*)$/\1/g; |
---|
| 275 | $t =~ s/[\/]_([a-z0-9][^\/]*)$/\/\1/g; |
---|
| 276 | return ($t); |
---|
| 277 | } |
---|
| 278 | |
---|
[1a300b9] | 279 | sub testStarted |
---|
| 280 | { |
---|
[e197f5] | 281 | local($v) = $_[0]; |
---|
| 282 | $v = testNameRemoveLeadingUnderscore($v); |
---|
[1a300b9] | 283 | putTCmsgNV2( "testStarted", "name", $v, "captureStandardOutput", "true"); |
---|
[ebb444] | 284 | $failed = 0; |
---|
[1a300b9] | 285 | } |
---|
| 286 | sub testFinished |
---|
| 287 | { |
---|
| 288 | local($v) = $_[0]; |
---|
| 289 | local($d) = $_[1]; |
---|
[e197f5] | 290 | $v = testNameRemoveLeadingUnderscore($v); |
---|
[ebb444] | 291 | putTCmsgNV2( "testFinished", "name", $v, "duration", $d); |
---|
| 292 | $failed = 0; |
---|
[1a300b9] | 293 | } |
---|
[ebb444] | 294 | |
---|
[1a300b9] | 295 | sub testFailed |
---|
| 296 | { |
---|
| 297 | local($n) = $_[0]; |
---|
| 298 | local($m) = $_[1]; |
---|
[e197f5] | 299 | |
---|
| 300 | $n = testNameRemoveLeadingUnderscore($n); |
---|
[ebb444] | 301 | |
---|
| 302 | if( !$failed ) |
---|
| 303 | { |
---|
| 304 | putTCmsgNV2( "testFailed", "name", $n, "message", $m); |
---|
| 305 | $failed = 1; |
---|
| 306 | } else |
---|
| 307 | { |
---|
| 308 | tcFailure("Test: $n => $m", ""); |
---|
| 309 | } |
---|
[1a300b9] | 310 | } |
---|
| 311 | sub testFailed2 |
---|
| 312 | { |
---|
| 313 | local($n) = tc_filter($_[0]); |
---|
| 314 | local($m) = tc_filter($_[1]); |
---|
| 315 | local($t) = tc_filter($_[2]); |
---|
[e197f5] | 316 | |
---|
| 317 | $n = testNameRemoveLeadingUnderscore($n); |
---|
| 318 | |
---|
[ebb444] | 319 | if( !$failed ) |
---|
| 320 | { |
---|
| 321 | putTCmsg( "testFailed", "name=\'$n\' message=\'$m\' details=\'$t\'"); |
---|
| 322 | $failed = 1; |
---|
| 323 | } else |
---|
| 324 | { |
---|
| 325 | tcFailure("Test: $n => $m", $t); |
---|
| 326 | } |
---|
| 327 | |
---|
[1a300b9] | 328 | } |
---|
| 329 | sub testFailedCMP |
---|
| 330 | { |
---|
[ebb444] | 331 | local($name) = tc_filter($_[0]); |
---|
| 332 | local($msg) = tc_filter($_[1]); |
---|
| 333 | local($details) = tc_filter($_[2]); |
---|
| 334 | local($expected) = tc_filter($_[3]); |
---|
| 335 | local($actual) = tc_filter($_[4]); |
---|
[e197f5] | 336 | |
---|
| 337 | $name = testNameRemoveLeadingUnderscore($name); |
---|
| 338 | |
---|
[ebb444] | 339 | if( !$failed ) |
---|
| 340 | { |
---|
| 341 | putTCmsg( "testFailed", "type=\'comparisonFailure\' name=\'$name\' message=\'$msg\' details=\'$details\' expected=\'$expected\' actual=\'$actual\'"); |
---|
| 342 | $failed = 1; |
---|
| 343 | } else |
---|
| 344 | { |
---|
| 345 | tcFailure("Test: $name => $msg", "$detail\nExpected: $expected\nActual: $actual"); |
---|
| 346 | } |
---|
| 347 | |
---|
[1a300b9] | 348 | } |
---|
| 349 | |
---|
[ebb444] | 350 | ##teamcity[testFailed type='comparisonFailure' name='test_file' message='failure_message' details='message and stack trace' expected='expected value' actual='actual value'] |
---|
[1a300b9] | 351 | sub testIgnored |
---|
| 352 | { |
---|
| 353 | local($n) = $_[0]; |
---|
| 354 | local($m) = $_[1]; |
---|
[e197f5] | 355 | |
---|
| 356 | $n = testNameRemoveLeadingUnderscore($n); |
---|
| 357 | |
---|
[1a300b9] | 358 | putTCmsgNV2( "testIgnored", "name", $n, "message", $m); |
---|
| 359 | } |
---|
| 360 | |
---|
| 361 | |
---|
| 362 | |
---|
[55f154] | 363 | ################################################################# |
---|
[b21d63] | 364 | # |
---|
[55f154] | 365 | # auxiallary routines |
---|
[b21d63] | 366 | # |
---|
[e960fdf] | 367 | |
---|
[31f293] | 368 | sub GetSingularVersionDate |
---|
| 369 | { |
---|
[93e538] | 370 | mysystem("$singular -t -v --execute=\"exit;\"> SingularVersionDate"); |
---|
[31f293] | 371 | open(FD, "<SingularVersionDate"); |
---|
| 372 | while (<FD>) |
---|
| 373 | { |
---|
| 374 | $singular_uname = (/for\s+([^\s]*)\s+/ ? $1 : "uname"); |
---|
| 375 | $singular_version = (/version\s+([^\s]*)\s+/ ? $1 : "0-0-0"); |
---|
| 376 | $singular_date = (/\((.*)\)/ ? $1 : "1970010100"); |
---|
| 377 | $this_time = time; |
---|
| 378 | last; |
---|
| 379 | } |
---|
| 380 | close(FD); |
---|
[93e538] | 381 | mysystem("if [ -e /proc/cpuinfo ]; then cat /proc/cpuinfo >> SingularVersionDate; fi "); |
---|
[4a7108c] | 382 | # mysystem("sysctl -a >> SingularVersionDate"); # sysctl is not a user cmd. |
---|
[93e538] | 383 | mysystem("uname -a >> SingularVersionDate"); |
---|
| 384 | mysystem("if [ -e /proc/meminfo ]; then cat /proc/meminfo >> SingularVersionDate; fi "); |
---|
[4a7108c] | 385 | # mysystem("free -h >> SingularVersionDate"); # nobody supports free -h |
---|
[31f293] | 386 | } |
---|
| 387 | |
---|
[d5e119] | 388 | sub Set_withMP |
---|
| 389 | { |
---|
| 390 | if (! $withMP) |
---|
| 391 | { |
---|
| 392 | $withMP = "no"; |
---|
[4c79e7] | 393 | open(MP_TEST, ">MPTest"); |
---|
| 394 | print(MP_TEST "system(\"with\", \"MP\"); \$"); |
---|
| 395 | close(MP_TEST); |
---|
[93e538] | 396 | mysystem("$singular -qt MPTest > withMPtest"); |
---|
[d5e119] | 397 | if (open(MP_TEST, "<withMPtest")) |
---|
| 398 | { |
---|
| 399 | $_ = <MP_TEST>; |
---|
| 400 | $withMP = "yes" if (/^1/); |
---|
| 401 | close(MP_TEST); |
---|
| 402 | } |
---|
[93e538] | 403 | mysystem("$rm -f withMPtest MPTest"); |
---|
[d5e119] | 404 | } |
---|
| 405 | } |
---|
[b21d63] | 406 | |
---|
| 407 | |
---|
[d5e119] | 408 | sub MPok |
---|
| 409 | { |
---|
| 410 | local($root) = $_[0]; |
---|
[b21d63] | 411 | |
---|
[d5e119] | 412 | if (! open(TST_FILE, "<$root.tst")) |
---|
| 413 | { |
---|
| 414 | print (STDERR "Can not open $root.tst for reading\n"); |
---|
| 415 | return (0); |
---|
| 416 | } |
---|
| 417 | while (<TST_FILE>) |
---|
| 418 | { |
---|
| 419 | if (/\"MP.+:.*\"/) |
---|
| 420 | { |
---|
| 421 | &Set_withMP; |
---|
| 422 | return (0) if ($withMP eq "no"); |
---|
| 423 | } |
---|
| 424 | } |
---|
| 425 | return (1); |
---|
| 426 | } |
---|
[e960fdf] | 427 | |
---|
[d5e119] | 428 | sub Diff |
---|
| 429 | { |
---|
| 430 | local($root) = $_[0]; |
---|
| 431 | local($exit_status); |
---|
[b21d63] | 432 | |
---|
| 433 | # prepare the result files: |
---|
[93e538] | 434 | mysystem("$cat \"$root.res\" | $tr -d '\\013' | $sed $sed_scripts > \"$root.res.cleaned\""); |
---|
| 435 | mysystem("$cat \"$root.new.res\" | $tr -d '\\013' | $sed $sed_scripts > \"$root.new.res.cleaned\""); |
---|
[d5e119] | 436 | |
---|
| 437 | # doo the diff call |
---|
[93e538] | 438 | $exit_status = mysystem("$diff -w -b \"$root.res.cleaned\" \"$root.new.res.cleaned\" > \"$root.diff\" 2>&1"); |
---|
[b21d63] | 439 | |
---|
[ebb444] | 440 | |
---|
[d5e119] | 441 | # clean up time |
---|
[93e538] | 442 | mysystem("$rm -f \"$root.res.cleaned\" \"$root.new.res.cleaned\""); |
---|
[b21d63] | 443 | |
---|
[d5e119] | 444 | # there seems to be a bug here somewhere: even if diff reported |
---|
| 445 | # differenceses and exited with status != 0, then system still |
---|
| 446 | # returns exit status 0. Hence we manually need to find out whether |
---|
[b21d63] | 447 | # or not differences were reported: |
---|
[d5e119] | 448 | # iff diff-file exists and has non-zero size |
---|
| 449 | $exit_status = $exit_status || (-e "$root.diff" && -s "$root.diff"); |
---|
| 450 | |
---|
[ebb444] | 451 | if( $exit_status && (length($teamcity) > 0) ) |
---|
| 452 | { |
---|
| 453 | local($details) = mysystem_catch("$cat \"$root.diff\""); |
---|
| 454 | local($expected) = mysystem_catch("$cat \"$root.res\""); |
---|
| 455 | local($actual) = mysystem_catch("$cat \"$root.new.res\""); |
---|
| 456 | testFailedCMP($test_file, "Differences in res files", $details, $expected, $actual ) |
---|
| 457 | } |
---|
| 458 | |
---|
[d5e119] | 459 | return($exit_status); |
---|
| 460 | } |
---|
[b21d63] | 461 | |
---|
[e960fdf] | 462 | sub tst_status_check |
---|
[b35b93] | 463 | { |
---|
| 464 | local($root) = $_[0]; |
---|
[e960fdf] | 465 | local($line,$new_line,$prefix,$crit,$res,$new_res); |
---|
| 466 | local($res_diff,$res_diff_pc,$res_diff_line); |
---|
[31f293] | 467 | my($exit_status, $reported) = (0, 0); |
---|
[e960fdf] | 468 | local($error_cause) = ""; |
---|
[b21d63] | 469 | |
---|
| 470 | open(RES_FILE, "<$root.stat") || |
---|
[e2114af] | 471 | return (1, "Can not open $root.stat \n"); |
---|
| 472 | open(NEW_RES_FILE, "<$root.new.stat") || |
---|
| 473 | return (1, "Can not open $root.new.stat \n"); |
---|
[a23d8e] | 474 | open(STATUS_DIFF_FILE, ">$root.stat.sdiff") || |
---|
| 475 | return (1, "Can not open $root.stat.sdiff \n"); |
---|
[e2114af] | 476 | |
---|
[31f293] | 477 | while (1) |
---|
[e960fdf] | 478 | { |
---|
[31f293] | 479 | while ($new_line = <NEW_RES_FILE>) |
---|
[e960fdf] | 480 | { |
---|
[31f293] | 481 | last if $new_line =~ /(\d+) >> (\w+) ::.*$hostname:(\d+)/ && $checks{$2}; |
---|
| 482 | } |
---|
| 483 | last unless $new_line =~ /(\d+) >> (\w+) ::.*$hostname:(\d+)/; |
---|
| 484 | $prefix = $1; |
---|
| 485 | $crit = $2; |
---|
| 486 | $new_res = $3; |
---|
| 487 | next unless $new_res > $mintime_val; |
---|
| 488 | |
---|
| 489 | while ($line = <RES_FILE>) |
---|
| 490 | { |
---|
| 491 | last if $line =~ /$prefix >> $crit ::.*?$hostname:(\d+)/; |
---|
| 492 | } |
---|
| 493 | last unless $line =~ /$prefix >> $crit ::.*?$hostname:(\d+)/; |
---|
| 494 | my $res_version; |
---|
| 495 | $res = 0; |
---|
[b21d63] | 496 | |
---|
[31f293] | 497 | # search for smallest |
---|
| 498 | while ($line =~ /([^\s]*)$hostname:(\d+)/g) |
---|
| 499 | { |
---|
| 500 | my $this_res = $2; |
---|
| 501 | my $this_res_version = $1; |
---|
| 502 | if ((!$res || $this_res <= $res) && (!$status_check_regexp || $this_res_version =~ /$status_check_regexp/)) |
---|
| 503 | { |
---|
| 504 | $res = $this_res; |
---|
| 505 | $res_version = $this_res_version; |
---|
[e960fdf] | 506 | } |
---|
| 507 | } |
---|
[31f293] | 508 | next unless $res; |
---|
| 509 | $res_diff = $new_res - $res; |
---|
| 510 | $res_diff_pc = int((($new_res / $res) - 1)*100); |
---|
| 511 | $res_diff_line = |
---|
| 512 | "$prefix >> $crit :: new:$new_res old:$res_version$res diff:$res_diff %:$res_diff_pc\n"; |
---|
| 513 | print STATUS_DIFF_FILE $res_diff_line; |
---|
| 514 | |
---|
| 515 | if ((defined($error{$crit}) && $error{$crit}<abs($res_diff_pc)) |
---|
| 516 | || |
---|
| 517 | (defined($report{$crit}) && $report{$crit}<abs($res_diff_pc))) |
---|
| 518 | { |
---|
| 519 | print "$prefix >> $crit :: new:$new_res old:$res diff:$res_diff %:$res_diff_pc\n" |
---|
| 520 | if ($verbosity > 0); |
---|
| 521 | } |
---|
| 522 | |
---|
| 523 | if ($exit_status == 0) |
---|
| 524 | { |
---|
| 525 | $exit_status = (defined($error{$crit}) |
---|
| 526 | && $error{$crit} < abs($res_diff_pc)); |
---|
| 527 | $error_cause = "Status error for $crit at $prefix\n" |
---|
| 528 | if ($exit_status); |
---|
| 529 | } |
---|
[e960fdf] | 530 | } |
---|
| 531 | close(RES_FILE); |
---|
| 532 | close(NEW_RES_FILE); |
---|
| 533 | close(STATUS_DIFF_FILE); |
---|
| 534 | return ($exit_status, $error_cause); |
---|
| 535 | } |
---|
[b35b93] | 536 | |
---|
[e960fdf] | 537 | sub tst_status_merge |
---|
| 538 | { |
---|
| 539 | local($root) = $_[0]; |
---|
| 540 | local($line, $new_line, $crit, $res); |
---|
[b21d63] | 541 | |
---|
[31f293] | 542 | GetSingularVersionDate() |
---|
| 543 | unless $singular_version; |
---|
| 544 | |
---|
| 545 | if (! -e "$root.stat") |
---|
| 546 | { |
---|
| 547 | open(RES_FILE, ">$root.stat") || |
---|
| 548 | return (1, "Can not open $root.stat \n"); |
---|
| 549 | open(NEW_RES_FILE, "<$root.new.stat") || |
---|
| 550 | return (1, "Can not open $root.new.stat \n"); |
---|
| 551 | |
---|
| 552 | while (<NEW_RES_FILE>) |
---|
| 553 | { |
---|
| 554 | if (/(\d+) >> (\w+) :: /) |
---|
| 555 | { |
---|
[1a300b9] | 556 | s/$hostname:(\d+)/$this_time:$singular_date:$singular_version:$singular_uname:$hostname:$1/g; |
---|
| 557 | print RES_FILE $_; |
---|
[31f293] | 558 | } |
---|
| 559 | } |
---|
| 560 | close(RES_FILE); |
---|
| 561 | close(NEW_RES_FILE); |
---|
| 562 | return; |
---|
| 563 | } |
---|
| 564 | |
---|
[b21d63] | 565 | open(RES_FILE, "<$root.stat") || |
---|
[e2114af] | 566 | return (1, "Can not open $root.stat \n"); |
---|
| 567 | open(NEW_RES_FILE, "<$root.new.stat") || |
---|
| 568 | return (1, "Can not open $root.new.stat \n"); |
---|
| 569 | open(TEMP_FILE, ">$root.tmp.stat") || |
---|
| 570 | return (1, "Can not open $root.tmp.stat \n"); |
---|
[b21d63] | 571 | |
---|
[31f293] | 572 | while (1) |
---|
[e960fdf] | 573 | { |
---|
[31f293] | 574 | while (($new_line = <NEW_RES_FILE>) && $new_line !~ /(\d+) >> (\w+) ::/){} |
---|
| 575 | last unless $new_line =~ /(\d+) >> (\w+) ::.*$hostname:(\d+)/; |
---|
| 576 | my $prefix = $1; |
---|
| 577 | my $crit = $2; |
---|
| 578 | my $new_res = "$this_time:$singular_date:$singular_version:$singular_uname:$hostname:$3"; |
---|
| 579 | while (($line = <RES_FILE>) && $line !~ /$prefix >> $crit ::/){} |
---|
| 580 | unless ($line) |
---|
[e960fdf] | 581 | { |
---|
[31f293] | 582 | close(RES_FILE); |
---|
| 583 | close(NEW_RES_FILE); |
---|
| 584 | close(TEMP_FILE); |
---|
[93e538] | 585 | mysystem("$rm \"$root.tmp.stat\""); |
---|
[31f293] | 586 | return (1, "Can not find '$prefix >> $crit' in $root.stat\n"); |
---|
| 587 | } |
---|
| 588 | if ($merge_version) |
---|
| 589 | { |
---|
| 590 | $line =~ s/[^ ]*:$singular_version:$singular_uname:$hostname:\d+//g; |
---|
| 591 | chop $line; |
---|
| 592 | $line .= " $new_res\n"; |
---|
[e960fdf] | 593 | } |
---|
| 594 | else |
---|
| 595 | { |
---|
[31f293] | 596 | chop $line; |
---|
| 597 | $line .= " $new_res\n"; |
---|
[e960fdf] | 598 | } |
---|
[31f293] | 599 | print TEMP_FILE $line; |
---|
[e960fdf] | 600 | } |
---|
[31f293] | 601 | |
---|
[e960fdf] | 602 | close(RES_FILE); |
---|
| 603 | close(NEW_RES_FILE); |
---|
| 604 | close(TEMP_FILE); |
---|
[93e538] | 605 | mysystem("$mv -f \"$root.tmp.stat\" \"$root.stat\""); |
---|
| 606 | mysystem("$rm -f \"$root.new.stat\" \"$root.stat.sdiff\"") unless $keep eq "yes"; |
---|
[31f293] | 607 | return ; |
---|
[e960fdf] | 608 | } |
---|
| 609 | |
---|
| 610 | sub tst_check |
---|
| 611 | { |
---|
| 612 | local($root) = $_[0]; |
---|
| 613 | local($system_call, $exit_status, $ignore_pattern, $error_cause); |
---|
[b21d63] | 614 | |
---|
[e197f5] | 615 | local($my_test_file) = testNameRemoveLeadingUnderscore($test_file); |
---|
| 616 | |
---|
| 617 | if (! ($my_test_file eq $test_file)) |
---|
| 618 | { |
---|
| 619 | tcLog("The test '$test_file' will be reported to TeamCity as '$my_test_file' as it was _renamed :-/"); |
---|
| 620 | } |
---|
| 621 | |
---|
[93e538] | 622 | if( exists($test_files{$test_file}) && (length($teamcity) > 0) ) |
---|
| 623 | { |
---|
| 624 | tcWarn("The test '$test_file' have been alreeady tests (with result: $test_files{$test_file})... skipping!"); |
---|
| 625 | return ($test_files{$test_file}) |
---|
| 626 | } |
---|
[6d01ca] | 627 | |
---|
[93e538] | 628 | $total_checks++; |
---|
| 629 | |
---|
[b35b93] | 630 | # check for existence/readablity of tst and res file |
---|
| 631 | if (! (-r "$root.tst")) |
---|
| 632 | { |
---|
[dfe914] | 633 | print "--- $root " unless ($verbosity == 0); |
---|
[b35b93] | 634 | print (STDERR "Can not read $root.tst\n"); |
---|
[1a300b9] | 635 | testIgnored($test_file, "Can not read $root.tst"); |
---|
[93e538] | 636 | $test_files{$test_file} = 1; |
---|
[b35b93] | 637 | return (1); |
---|
| 638 | } |
---|
[b21d63] | 639 | |
---|
[d5e119] | 640 | # ignore MP stuff, if this singular does not have MP |
---|
[93e538] | 641 | if (! MPok($root)) |
---|
[d5e119] | 642 | { |
---|
[dfe914] | 643 | print "--- $root " unless ($verbosity == 0); |
---|
[d5e119] | 644 | print "Warning: $root not tested: needs MP\n"; |
---|
[1a300b9] | 645 | testIgnored($test_file, "Warning: $root not tested: needs MP"); |
---|
[93e538] | 646 | $test_files{$test_file} = 0; |
---|
[d5e119] | 647 | return (0); |
---|
| 648 | } |
---|
[b21d63] | 649 | |
---|
[d5e119] | 650 | # generate $root.res |
---|
[6d01ca] | 651 | if ($generate ne "yes" && ! defined($mtrack) && !defined($timings_only)) |
---|
[b35b93] | 652 | { |
---|
[49d361] | 653 | if ((-r "$root.res.gz.uu") && ! ( -z "$root.res.gz.uu")) |
---|
[b35b93] | 654 | { |
---|
[93e538] | 655 | $exit_status = mysystem("$uudecode \"$root.res.gz.uu\" > /dev/null 2>&1; $gunzip -f \"$root.res.gz\""); |
---|
[b35b93] | 656 | if ($exit_status) |
---|
| 657 | { |
---|
[dfe914] | 658 | print "--- $root " unless ($verbosity == 0); |
---|
[b21d63] | 659 | print (STDERR "Can not decode $root.res.gz.uu\n"); |
---|
[1a300b9] | 660 | testIgnored($test_file, "Can not decode $root.res.gz.uu"); |
---|
[93e538] | 661 | $test_files{$test_file} = $exit_status; |
---|
[b21d63] | 662 | return ($exit_status); |
---|
[b35b93] | 663 | } |
---|
| 664 | } |
---|
[49d361] | 665 | elsif (! (-r "$root.res") || ( -z "$root.res")) |
---|
| 666 | { |
---|
[dfe914] | 667 | print "--- $root " unless ($verbosity == 0); |
---|
[49d361] | 668 | print (STDERR "Can not read $root.res[.gz.uu]\n"); |
---|
[1a300b9] | 669 | testIgnored($test_file, "Can not read $root.res[.gz.uu]"); |
---|
[93e538] | 670 | $test_files{$test_file} = 1; |
---|
[49d361] | 671 | return (1); |
---|
| 672 | } |
---|
[b35b93] | 673 | } |
---|
[e960fdf] | 674 | |
---|
[1a300b9] | 675 | testStarted($test_file); |
---|
[dfe914] | 676 | print "--- $root " unless ($verbosity == 0); |
---|
[1a300b9] | 677 | |
---|
[f5128b8] | 678 | my $resfile = "\"$root.new.res\""; |
---|
| 679 | $resfile = "\"$root.mtrack.res\"" if (defined($mtrack)); |
---|
[31f293] | 680 | my $statfile = "$root.new.stat"; |
---|
[93e538] | 681 | mysystem("$rm -f \"$statfile\""); |
---|
[1a300b9] | 682 | |
---|
[0b20296] | 683 | if (defined($mtrack)) |
---|
[b35b93] | 684 | { |
---|
[f5128b8] | 685 | $system_call = "$cat \"$root.tst\" | sed -e 's/\\\\\$/LIB \"general.lib\"; killall(); killall(\"proc\");kill killall;system(\"mtrack\", \"$root.mtrack.unused\", $mtrack); \\\$/' | $singular $singularOptions "; |
---|
[6d01ca] | 686 | $system_call .= ($verbosity > 3 ? " | $tee " : " > "); |
---|
[f5128b8] | 687 | $system_call .= "\"$root.mtrack.res\""; |
---|
[6d01ca] | 688 | $system_call .= " 2>&1 " if ($verbosity <= 3); |
---|
[b35b93] | 689 | } |
---|
| 690 | else |
---|
| 691 | { |
---|
[31f293] | 692 | |
---|
[9a50a2] | 693 | # prepare Singular run |
---|
[6d01ca] | 694 | if ($verbosity > 3 && !$WINNT) |
---|
[9a50a2] | 695 | { |
---|
[f5128b8] | 696 | $system_call = "$cat \"$root.tst\" | $singular --execute 'string tst_status_file=\"$statfile\";' $singularOptions | $tee $resfile"; |
---|
[9a50a2] | 697 | } |
---|
| 698 | else |
---|
| 699 | { |
---|
[f5128b8] | 700 | $system_call = "$cat \"$root.tst\" | $singular --execute 'string tst_status_file=\"$statfile\";' $singularOptions > $resfile 2>&1"; |
---|
[9a50a2] | 701 | } |
---|
[b35b93] | 702 | } |
---|
| 703 | # Go Singular, Go! |
---|
[6d01ca] | 704 | |
---|
| 705 | my ($user_t,$system_t,$cuser_t,$csystem_t) = times; |
---|
[93e538] | 706 | $exit_status = mysystem($system_call); |
---|
[6d01ca] | 707 | my ($user_t,$system_t,$cuser_t2,$csystem_t2) = times; |
---|
| 708 | $cuser_t = $cuser_t2 - $cuser_t; |
---|
| 709 | $csystem_t = $csystem_t2 - $csystem_t; |
---|
[ebb444] | 710 | |
---|
| 711 | tcLog("Test: $test_file, user time: $cuser_t, system time: $csystem_t" ); |
---|
| 712 | |
---|
[e960fdf] | 713 | if ($exit_status != 0) |
---|
[b35b93] | 714 | { |
---|
[ebb444] | 715 | $error_cause = "Singular call exited with status ($exit_status) != 0"; |
---|
| 716 | |
---|
| 717 | if( length($teamcity) > 0 ) |
---|
| 718 | { |
---|
| 719 | ### TODO: add a way to detect timeout!!! |
---|
| 720 | if( $exit_status == 142 ) # perl sig alarm exit code? NOPE :((( |
---|
| 721 | { |
---|
| 722 | local($details) = mysystem_catch("$cat \"$resfile\""); |
---|
| 723 | testFailed2($test_file, "Exit on timeout ($timeout sec)!", $details); |
---|
| 724 | } |
---|
| 725 | } |
---|
[b35b93] | 726 | } |
---|
[e960fdf] | 727 | else |
---|
[b35b93] | 728 | { |
---|
[e960fdf] | 729 | # check for Segment fault in res file |
---|
[93e538] | 730 | $exit_status = ! (mysystem("$grep \"Segment fault\" $resfile > /dev/null 2>&1")); |
---|
[b21d63] | 731 | |
---|
[e960fdf] | 732 | if ($exit_status) |
---|
| 733 | { |
---|
| 734 | $error_cause = "Segment fault"; |
---|
[ebb444] | 735 | local($details) = mysystem_catch("$cat \"$resfile\""); |
---|
| 736 | testFailed2($test_file, $error_cause, $details); |
---|
[e960fdf] | 737 | } |
---|
[6d01ca] | 738 | elsif (! defined($mtrack) && !defined($timings_only)) |
---|
[e960fdf] | 739 | { |
---|
[93e538] | 740 | mysystem("$rm -f \"$root.diff\""); |
---|
[e960fdf] | 741 | if ($generate eq "yes") |
---|
| 742 | { |
---|
[93e538] | 743 | mysystem("$cp $resfile \"$root.res\""); |
---|
[e960fdf] | 744 | } |
---|
[b21d63] | 745 | else |
---|
[e960fdf] | 746 | { |
---|
[b21d63] | 747 | # call Diff |
---|
[93e538] | 748 | $exit_status = Diff($root); |
---|
[b21d63] | 749 | if ($exit_status) |
---|
| 750 | { |
---|
[2ae411d] | 751 | unless ($verbosity == 0) |
---|
| 752 | { |
---|
| 753 | print "\n"; |
---|
[f5128b8] | 754 | mysystem("$cat \"$root.diff\""); |
---|
[2ae411d] | 755 | } |
---|
[b21d63] | 756 | $error_cause = "Differences in res files"; |
---|
| 757 | } |
---|
| 758 | else |
---|
| 759 | { |
---|
[93e538] | 760 | mysystem("$rm -f \"$root.diff\""); |
---|
[b21d63] | 761 | } |
---|
[e960fdf] | 762 | } |
---|
| 763 | } |
---|
[b35b93] | 764 | } |
---|
[e960fdf] | 765 | |
---|
[f5128b8] | 766 | |
---|
| 767 | |
---|
| 768 | mysystem("mv tst_status.out \"$statfile\"") |
---|
[31f293] | 769 | if (! -e $statfile && -e "tst_status.out"); |
---|
| 770 | |
---|
[0b20296] | 771 | if (%checks && ! $exit_status && $generate ne "yes" && ! defined($mtrack)) |
---|
[e2114af] | 772 | { |
---|
[31f293] | 773 | if (-e "$statfile") |
---|
[a21c9c] | 774 | { |
---|
| 775 | # do status checks |
---|
[93e538] | 776 | ($exit_status, $error_cause) = tst_status_check($root); |
---|
[a21c9c] | 777 | } |
---|
[f50a14] | 778 | else |
---|
| 779 | { |
---|
[31f293] | 780 | print "Warning: no file $statfile\n"; |
---|
[93e538] | 781 | tcWarn("Warning: no file $statfile"); |
---|
[f50a14] | 782 | } |
---|
[e2114af] | 783 | } |
---|
[b21d63] | 784 | |
---|
| 785 | |
---|
[b35b93] | 786 | # complain even if verbosity == 0 |
---|
[e960fdf] | 787 | if ($exit_status) |
---|
[b35b93] | 788 | { |
---|
[2ae411d] | 789 | if (! -e "$root.diff") |
---|
| 790 | { |
---|
| 791 | open (DIFF_FILE, ">$root.diff"); |
---|
| 792 | print DIFF_FILE "!!! $root : $error_cause\n"; |
---|
| 793 | print "\n"; |
---|
| 794 | } |
---|
| 795 | print STDERR "!!! $root : $error_cause\n"; |
---|
[ebb444] | 796 | |
---|
| 797 | if( length($teamcity) > 0 ) |
---|
| 798 | { |
---|
| 799 | local($details) = mysystem_catch("$cat \"$resfile\""); |
---|
| 800 | testFailed2($test_file, $error_cause, $details); |
---|
| 801 | } |
---|
[b35b93] | 802 | } |
---|
[e960fdf] | 803 | else |
---|
[d5e119] | 804 | { |
---|
[0b20296] | 805 | unless (defined($mtrack)) |
---|
[b35b93] | 806 | { |
---|
[9a50a2] | 807 | #clean up |
---|
| 808 | if ($generate eq "yes") |
---|
[e2114af] | 809 | { |
---|
[f5128b8] | 810 | mysystem("$rm -f \"$root.stat\"") unless %merge; |
---|
[31f293] | 811 | ($exit_status, $error_cause) = tst_status_merge($root); |
---|
[9a50a2] | 812 | if (! $WINNT) |
---|
| 813 | { |
---|
[93e538] | 814 | mysystem("$gzip -cf \"$root.res\" | $uuencode \"$root.res.gz\" > \"$root.res.gz.uu\""); |
---|
[9a50a2] | 815 | } |
---|
| 816 | else |
---|
| 817 | { |
---|
| 818 | # uuencode is broken under windows |
---|
| 819 | print "Warning: Can not generate $root.res.gz.uu under Windows\n"; |
---|
| 820 | } |
---|
[e2114af] | 821 | } |
---|
[9a50a2] | 822 | elsif (%merge) |
---|
[e2114af] | 823 | { |
---|
[93e538] | 824 | ($exit_status, $error_cause) = tst_status_merge($root); |
---|
[9a50a2] | 825 | |
---|
[31f293] | 826 | print (STDERR "Warning: Merge Problems: $error_cause\n") |
---|
| 827 | if ($verbosity > 0 && $exit_status); |
---|
[e2114af] | 828 | } |
---|
| 829 | } |
---|
[e960fdf] | 830 | if ($keep ne "yes") |
---|
[d5e119] | 831 | { |
---|
[93e538] | 832 | mysystem("$rm -f tst_status.out $resfile \"$root.res\" \"$root.diff\" \"$root.new.stat\""); |
---|
[b21d63] | 833 | } |
---|
[b35b93] | 834 | } |
---|
[d5e119] | 835 | # und tschuess |
---|
[2ae411d] | 836 | unless ($verbosity == 0 || $exit_status) |
---|
[6d01ca] | 837 | { |
---|
| 838 | if ($verbosity > 1 || $timings_only) |
---|
| 839 | { |
---|
| 840 | my $used_time = $cuser_t + $csystem_t; |
---|
| 841 | $total_used_time += $used_time; |
---|
| 842 | $lst_used_time += $used_time; |
---|
| 843 | print " " x (23 - length($root)); |
---|
| 844 | printf("%.2f", $used_time); |
---|
| 845 | } |
---|
| 846 | print " \n"; |
---|
| 847 | } |
---|
[2ae411d] | 848 | $total_checks_pass++ unless $exit_status; |
---|
[f5128b8] | 849 | |
---|
[93e538] | 850 | mysystem("mv gmon.out \"gmon.$root.out\"") if (-e "gmon.out"); |
---|
[ebb444] | 851 | |
---|
[1a300b9] | 852 | testFinished($test_file, $cuser_t + $csystem_t); |
---|
| 853 | |
---|
[93e538] | 854 | $test_files{$test_file} = $exit_status; |
---|
[b35b93] | 855 | return ($exit_status); |
---|
| 856 | } |
---|
| 857 | |
---|
| 858 | |
---|
| 859 | ################################################################# |
---|
[b21d63] | 860 | # |
---|
[b35b93] | 861 | # Main program |
---|
[b21d63] | 862 | # |
---|
[b35b93] | 863 | |
---|
| 864 | # process switches |
---|
| 865 | while ($ARGV[0] =~ /^-/) |
---|
| 866 | { |
---|
| 867 | $_ = shift; |
---|
| 868 | if (/^-s$/) |
---|
| 869 | { |
---|
| 870 | $singular = shift; |
---|
| 871 | } |
---|
| 872 | elsif (/^-h$/) |
---|
| 873 | { |
---|
| 874 | &Usage && exit (0); |
---|
| 875 | } |
---|
| 876 | elsif (/^-k$/) |
---|
| 877 | { |
---|
| 878 | $keep = "yes"; |
---|
| 879 | } |
---|
| 880 | elsif (/^-g$/) |
---|
| 881 | { |
---|
| 882 | $generate = "yes"; |
---|
| 883 | } |
---|
| 884 | elsif(/^-v$/) |
---|
| 885 | { |
---|
| 886 | $verbosity = shift; |
---|
| 887 | } |
---|
[0b20296] | 888 | elsif (/^-tt/) |
---|
| 889 | { |
---|
| 890 | $mtrack = shift; |
---|
| 891 | } |
---|
[a7bb142] | 892 | elsif (/^-A/) |
---|
| 893 | { |
---|
| 894 | $timeout = shift; |
---|
| 895 | } |
---|
[1a300b9] | 896 | elsif (/^-C$/) |
---|
| 897 | { |
---|
| 898 | $teamcity = shift; |
---|
| 899 | } |
---|
[9a50a2] | 900 | elsif(/^-t$/) |
---|
| 901 | { |
---|
| 902 | $mtrack = 1; |
---|
| 903 | } |
---|
[6d01ca] | 904 | elsif (/^-T/) |
---|
| 905 | { |
---|
| 906 | $timings_only = 1; |
---|
| 907 | } |
---|
[e960fdf] | 908 | elsif(/^-r$/) |
---|
| 909 | { |
---|
| 910 | $crit = "all"; |
---|
| 911 | $val = $report_val; |
---|
| 912 | if ($ARGV[0] =~ /.*%.*/) |
---|
| 913 | { |
---|
| 914 | ($crit, $val) = split(/%/, shift); |
---|
| 915 | } |
---|
[b21d63] | 916 | elsif ($ARGV[0] && |
---|
| 917 | $ARGV[0] !~ /^-/ && $ARGV[0] !~ /.*\.tst/ && $ARGV[0] !~ /.*\.lst/) |
---|
[e960fdf] | 918 | { |
---|
| 919 | $crit = shift; |
---|
| 920 | } |
---|
| 921 | if ($crit eq "all") |
---|
| 922 | { |
---|
| 923 | $report{"tst_memory_0"} = $val; |
---|
| 924 | $report{"tst_memory_1"} = $val; |
---|
| 925 | $report{"tst_memory_2"} = $val; |
---|
| 926 | $report{"tst_timer"} = $val; |
---|
| 927 | $report{"tst_timer_1"} = $val; |
---|
[b21d63] | 928 | $checks{"tst_memory_0"} = 1; |
---|
[e960fdf] | 929 | $checks{"tst_memory_1"} = 1; |
---|
[b21d63] | 930 | $checks{"tst_memory_2"} = 1; |
---|
| 931 | $checks{"tst_timer"} = 1; |
---|
| 932 | $checks{"tst_timer_1"} = 1; |
---|
[e960fdf] | 933 | } |
---|
| 934 | else |
---|
| 935 | { |
---|
| 936 | $report{$crit} = $val; |
---|
| 937 | $checks{$crit} = 1; |
---|
| 938 | } |
---|
| 939 | } |
---|
| 940 | elsif(/^-e$/) |
---|
| 941 | { |
---|
| 942 | $crit = "all"; |
---|
| 943 | $val = $error_val; |
---|
| 944 | if ($ARGV[0] =~ /.*%.*/) |
---|
| 945 | { |
---|
| 946 | ($crit, $val) = split(/%/, shift); |
---|
| 947 | } |
---|
[b21d63] | 948 | elsif ($ARGV[0] && |
---|
| 949 | $ARGV[0] !~ /^-/ && $ARGV[0] !~ /.*\.tst/ && $ARGV[0] !~ /.*\.lst/) |
---|
[e960fdf] | 950 | { |
---|
| 951 | $crit = shift; |
---|
| 952 | } |
---|
| 953 | if ($crit eq "all") |
---|
| 954 | { |
---|
| 955 | $error{"tst_memory_0"} = $val; |
---|
| 956 | $error{"tst_memory_1"} = $val; |
---|
| 957 | $error{"tst_memory_2"} = $val; |
---|
| 958 | $error{"tst_timer"} = $val; |
---|
| 959 | $error{"tst_timer_1"} = $val; |
---|
[b21d63] | 960 | $checks{"tst_memory_0"} = 1; |
---|
[e960fdf] | 961 | $checks{"tst_memory_1"} = 1; |
---|
[b21d63] | 962 | $checks{"tst_memory_2"} = 1; |
---|
| 963 | $checks{"tst_timer"} = 1; |
---|
| 964 | $checks{"tst_timer_1"} = 1; |
---|
[e960fdf] | 965 | } |
---|
| 966 | else |
---|
| 967 | { |
---|
| 968 | $error{$crit} = $val; |
---|
| 969 | $checks{$crit} = 1; |
---|
| 970 | } |
---|
| 971 | } |
---|
[31f293] | 972 | elsif(/^-a/ || /^-m/) |
---|
[e960fdf] | 973 | { |
---|
[31f293] | 974 | $merge_version = 1 if /^-m/; |
---|
[b21d63] | 975 | if ($ARGV[0] && |
---|
| 976 | $ARGV[0] !~ /^-/ && $ARGV[0] !~ /.*\.tst/ && $ARGV[0] !~ /.*\.lst/) |
---|
[e960fdf] | 977 | { |
---|
| 978 | $crit = shift; |
---|
| 979 | $merge{$crit} = 1; |
---|
| 980 | } |
---|
| 981 | else |
---|
| 982 | { |
---|
[b21d63] | 983 | $merge{"tst_memory_0"} = 1; |
---|
[e960fdf] | 984 | $merge{"tst_memory_1"} = 1; |
---|
[b21d63] | 985 | $merge{"tst_memory_2"} = 1; |
---|
| 986 | $merge{"tst_timer"} = 1; |
---|
| 987 | $merge{"tst_timer_1"} = 1; |
---|
[e960fdf] | 988 | } |
---|
| 989 | } |
---|
[31f293] | 990 | elsif (/^-c/) |
---|
| 991 | { |
---|
| 992 | $status_check_regexp = shift; |
---|
| 993 | } |
---|
[b21d63] | 994 | else |
---|
[b35b93] | 995 | { |
---|
| 996 | print (STDERR "Unrecognised option: $_\n") && &Usage && die; |
---|
| 997 | } |
---|
| 998 | } |
---|
| 999 | |
---|
| 1000 | # if no command line arguments are left, use regress.lst |
---|
| 1001 | if ($#ARGV == -1) |
---|
| 1002 | { |
---|
| 1003 | $ARGV[0] = "regress.lst"; |
---|
| 1004 | } |
---|
| 1005 | |
---|
| 1006 | # make sure $singular exists and is executable |
---|
[55f154] | 1007 | $singular = "$curr_dir/$singular" unless ($singular =~ /^\/.*/); |
---|
[d5e119] | 1008 | |
---|
[4c79e7] | 1009 | if ( ! (-e $singular)) |
---|
| 1010 | { |
---|
| 1011 | $singular = "$singular$ext" if ($WINNT && $singular !~ /.*$ext$/); |
---|
| 1012 | } |
---|
| 1013 | |
---|
[b35b93] | 1014 | if ( ! (-e $singular)) |
---|
| 1015 | { |
---|
| 1016 | print (STDERR "Can not find $singular \n") && &Usage && die; |
---|
| 1017 | } |
---|
[4c79e7] | 1018 | |
---|
| 1019 | if (! (-x $singular) && (! WINNT)) |
---|
[b35b93] | 1020 | { |
---|
[d5e119] | 1021 | print (STDERR "Can not execute $singular \n") && &Usage && die; |
---|
| 1022 | } |
---|
| 1023 | if (-d $singular) |
---|
| 1024 | { |
---|
| 1025 | print (STDERR "$singular is a directory\n") && &Usage && die; |
---|
[b35b93] | 1026 | } |
---|
| 1027 | |
---|
[867952] | 1028 | sub ViewFile |
---|
| 1029 | { |
---|
| 1030 | local($f) = $_[0]; |
---|
| 1031 | |
---|
| 1032 | local($ff) = myGetTCprop($f); |
---|
| 1033 | local($b) = "$f: " . $ff; |
---|
| 1034 | |
---|
| 1035 | blockOpened ($b); |
---|
[93e538] | 1036 | mysystem("cat " . $ff); |
---|
[867952] | 1037 | blockClosed ($b); |
---|
| 1038 | } |
---|
| 1039 | |
---|
[663baa] | 1040 | |
---|
[e1b6326] | 1041 | # if( length($teamcity) > 0 ) |
---|
| 1042 | # { |
---|
| 1043 | # # tcLog("|Hi|\r I\'m [Alex]|\nHow are You?|"); |
---|
| 1044 | # |
---|
| 1045 | # blockOpened ("init"); |
---|
| 1046 | # |
---|
| 1047 | # # print ("TEAMCITY_BUILD_PROPERTIES_FILE: $ENV{TEAMCITY_BUILD_PROPERTIES_FILE}" ); |
---|
| 1048 | # |
---|
| 1049 | # tcLog("TEAMCITY_BUILD_PROPERTIES_FILE: $ENV{TEAMCITY_BUILD_PROPERTIES_FILE}"); |
---|
| 1050 | # |
---|
| 1051 | # if ( length("$ENV{TEAMCITY_BUILD_PROPERTIES_FILE}") > 0 ) |
---|
| 1052 | # { |
---|
| 1053 | # print( "teamcity.tests.runRiskGroupTestsFirst: " . myGetTCprop("teamcity.tests.runRiskGroupTestsFirst") . "\n" ); |
---|
| 1054 | # |
---|
| 1055 | # ViewFile("teamcity.tests.recentlyFailedTests.file"); |
---|
| 1056 | # ViewFile("teamcity.build.changedFiles.file"); |
---|
| 1057 | # ViewFile("teamcity.build.properties.file"); |
---|
| 1058 | # ViewFile("teamcity.configuration.properties.file"); |
---|
| 1059 | # ViewFile("teamcity.runner.properties.file"); |
---|
| 1060 | # } |
---|
| 1061 | # |
---|
| 1062 | # blockClosed ("init"); |
---|
| 1063 | # } |
---|
[1a300b9] | 1064 | |
---|
[a7bb142] | 1065 | if ($timeout > 0) |
---|
| 1066 | { |
---|
[ebb444] | 1067 | $singular = "PERL_SIGNALS=unsafe perl -e 'alarm($timeout);exec(\@ARGV);' $singular"; |
---|
[1a300b9] | 1068 | tcLog ("Set exec timeout to $timeout sec.\n"); |
---|
[a7bb142] | 1069 | # die; |
---|
| 1070 | } |
---|
[1a300b9] | 1071 | |
---|
[394beb] | 1072 | # testSuiteStarted($teamcity); |
---|
[1a300b9] | 1073 | |
---|
[663baa] | 1074 | # now do the work |
---|
| 1075 | foreach (@ARGV) |
---|
[b35b93] | 1076 | { |
---|
[52f5a58] | 1077 | if( /^([^:]*): *(.*)$/ ) |
---|
| 1078 | { |
---|
| 1079 | $_=$2; |
---|
| 1080 | } |
---|
| 1081 | |
---|
| 1082 | if ( /^\s*([^ ].*)$/ ) |
---|
| 1083 | { |
---|
| 1084 | $_ = $1; |
---|
| 1085 | } |
---|
| 1086 | |
---|
| 1087 | if ( /^\.\/(.*)$/ ) |
---|
| 1088 | { |
---|
| 1089 | $_ = $1; |
---|
| 1090 | } |
---|
| 1091 | |
---|
[1a300b9] | 1092 | $test_file = $_; |
---|
[b35b93] | 1093 | |
---|
[1a300b9] | 1094 | tcLog("test_file: $test_file"); |
---|
[52f5a58] | 1095 | |
---|
[b21d63] | 1096 | if ( /^(.*)\.([^\.\/]*)$/ ) |
---|
[d5e119] | 1097 | { |
---|
| 1098 | $_ = $1; |
---|
| 1099 | $extension = $2; |
---|
[52f5a58] | 1100 | } else |
---|
| 1101 | { |
---|
[010b3f] | 1102 | # print ("Wrong input: [$_] has no extension!"); |
---|
| 1103 | # tcWarn("Wrong input: [$_] has no extension!"); |
---|
[52f5a58] | 1104 | next; |
---|
[d5e119] | 1105 | } |
---|
[52f5a58] | 1106 | |
---|
| 1107 | |
---|
| 1108 | |
---|
| 1109 | |
---|
[d5e119] | 1110 | |
---|
[b21d63] | 1111 | if ( /^(.*)\/([^\/]*)$/ ) |
---|
[d5e119] | 1112 | { |
---|
| 1113 | $path = $1; |
---|
| 1114 | $base = $2; |
---|
| 1115 | chdir($path); |
---|
[6d01ca] | 1116 | print "cd $path\n" if ($verbosity > 2); |
---|
[b21d63] | 1117 | } |
---|
| 1118 | else |
---|
[d5e119] | 1119 | { |
---|
| 1120 | $path = ""; |
---|
| 1121 | $base = $_; |
---|
| 1122 | } |
---|
[1a300b9] | 1123 | |
---|
| 1124 | tcLog("path: $path, base: $base, extension: $extension"); |
---|
| 1125 | |
---|
[d5e119] | 1126 | $file = "$base.$extension"; |
---|
| 1127 | chop ($tst_curr_dir = `pwd`); |
---|
[b21d63] | 1128 | |
---|
[b35b93] | 1129 | if ($extension eq "tst") |
---|
| 1130 | { |
---|
[93e538] | 1131 | $exit_code = tst_check($base) || $exit_code; |
---|
[b35b93] | 1132 | } |
---|
| 1133 | elsif ($extension eq "lst") |
---|
| 1134 | { |
---|
[d5e119] | 1135 | if (! open(LST_FILE, "<$file")) |
---|
[b35b93] | 1136 | { |
---|
[d5e119] | 1137 | print (STDERR "Can not open $path/$file for reading\n"); |
---|
[b35b93] | 1138 | $exit_code = 1; |
---|
[1a300b9] | 1139 | testIgnored($test_file, "Can not open $path/$file for reading"); |
---|
[b35b93] | 1140 | next; |
---|
| 1141 | } |
---|
[1a300b9] | 1142 | |
---|
| 1143 | local ($b) = $test_file; |
---|
| 1144 | blockOpened ($b); |
---|
| 1145 | |
---|
[6d01ca] | 1146 | $lst_used_time = 0; |
---|
| 1147 | $lst_checks = 0; |
---|
| 1148 | $lst_checks_pass = 0; |
---|
[b35b93] | 1149 | while (<LST_FILE>) |
---|
| 1150 | { |
---|
[d5e119] | 1151 | if (/^;/) # ignore lines starting with ; |
---|
[b35b93] | 1152 | { |
---|
[663baa] | 1153 | print unless ($verbosity == 0); |
---|
[b21d63] | 1154 | next; |
---|
[b35b93] | 1155 | } |
---|
[52f5a58] | 1156 | if( /^([^:]*): *(.*)$/ ) |
---|
| 1157 | { |
---|
| 1158 | $_=$2; |
---|
| 1159 | } |
---|
| 1160 | |
---|
| 1161 | if ( /^\s*([^\s].*)$/ ) |
---|
| 1162 | { |
---|
| 1163 | $_ = $1; |
---|
| 1164 | } |
---|
| 1165 | |
---|
| 1166 | if ( /^\.\/(.*)$/ ) |
---|
| 1167 | { |
---|
| 1168 | $_ = $1; |
---|
| 1169 | } |
---|
| 1170 | |
---|
[d5e119] | 1171 | next if (/^\s*$/); #ignore whitespaced lines |
---|
[663baa] | 1172 | chop if (/\n$/); #chop of \n |
---|
[1a300b9] | 1173 | |
---|
| 1174 | tcLog("path: $path, test_file: $_, file: $file"); |
---|
| 1175 | |
---|
| 1176 | if (length($path) > 0) |
---|
| 1177 | { |
---|
| 1178 | $test_file = "$path/$_"; |
---|
| 1179 | } |
---|
| 1180 | else |
---|
| 1181 | { |
---|
| 1182 | $test_file = $_; |
---|
| 1183 | } |
---|
[52f5a58] | 1184 | |
---|
| 1185 | $test_file =~ s/^[ ]*\.\///; |
---|
[1a300b9] | 1186 | |
---|
| 1187 | |
---|
| 1188 | $_ = $1 if (/^(.*)\.([^\.\/]*)$/ ); # chop of extension (.tst!!!?) |
---|
[b21d63] | 1189 | if ( /^(.*)\/([^\/]*)$/ ) |
---|
[d5e119] | 1190 | { |
---|
[b21d63] | 1191 | $tst_path = $1; |
---|
| 1192 | $tst_base = $2; |
---|
[d5e119] | 1193 | chdir($tst_path); |
---|
[6d01ca] | 1194 | print "cd $tst_path\n" if ($verbosity > 2); |
---|
[b21d63] | 1195 | } |
---|
| 1196 | else |
---|
[d5e119] | 1197 | { |
---|
[b21d63] | 1198 | $tst_path = ""; |
---|
| 1199 | $tst_base = $_; |
---|
[d5e119] | 1200 | } |
---|
[9a50a2] | 1201 | $tst_base =~ s/^\s*//; |
---|
| 1202 | $tst_base =~ s/(.*?)\s+.*/$1/; |
---|
[6d01ca] | 1203 | $lst_checks++; |
---|
[1a300b9] | 1204 | |
---|
| 1205 | tcLog("tst_path: $tst_path, tst_base: $tst_base"); |
---|
| 1206 | |
---|
[93e538] | 1207 | my $this_exit_code = tst_check($tst_base); |
---|
[1a300b9] | 1208 | |
---|
[6d01ca] | 1209 | $lst_checks_pass++ unless $this_exit_code; |
---|
| 1210 | $exit_code = $this_exit_code || $exit_code; |
---|
[d5e119] | 1211 | |
---|
| 1212 | if ($tst_path ne "") |
---|
| 1213 | { |
---|
[b21d63] | 1214 | chdir($tst_curr_dir); |
---|
[6d01ca] | 1215 | print "cd $tst_curr_dir\n" if ($verbosity > 2); |
---|
[d5e119] | 1216 | } |
---|
[b35b93] | 1217 | } |
---|
| 1218 | close (LST_FILE); |
---|
[93e538] | 1219 | |
---|
| 1220 | printf("$base Summary: Checks:$lst_checks Failed:%d Time:%.2f\n", $lst_checks - $lst_checks_pass, $lst_used_time) |
---|
[1a300b9] | 1221 | unless ($verbosity < 2); |
---|
[93e538] | 1222 | |
---|
| 1223 | tcLog( sprintf("list '$base' Summary: Checks:$lst_checks Failed:%d Time:%.2f", $lst_checks - $lst_checks_pass, $lst_used_time) ); |
---|
[1a300b9] | 1224 | blockClosed ($b); |
---|
[b35b93] | 1225 | } |
---|
| 1226 | else |
---|
| 1227 | { |
---|
| 1228 | print (STDERR "Unknown extension of $_: Need extension lst or tst\n"); |
---|
| 1229 | $exit_code = 1; |
---|
| 1230 | } |
---|
[d5e119] | 1231 | if ($path ne "") |
---|
| 1232 | { |
---|
[663baa] | 1233 | chdir($curr_dir); |
---|
[6d01ca] | 1234 | print "cd $curr_dir\n" if ($verbosity > 2); |
---|
[d5e119] | 1235 | } |
---|
[b35b93] | 1236 | } |
---|
| 1237 | |
---|
[6d01ca] | 1238 | unless ($verbosity < 2 || $lst_checks == $total_checks) |
---|
| 1239 | { |
---|
| 1240 | printf("Summary: Checks:$total_checks Failed:%d Time:%.2f\n", $total_checks - $total_checks_pass, $total_used_time); |
---|
| 1241 | } |
---|
| 1242 | |
---|
[93e538] | 1243 | tcLog( sprintf("Global Summary: Checks:$total_checks Failed:%d Time:%.2f", $total_checks - $total_checks_pass, $total_used_time)) ; |
---|
| 1244 | |
---|
[1a300b9] | 1245 | if( length($teamcity) > 0 ) |
---|
| 1246 | { |
---|
[394beb] | 1247 | # testSuiteFinished($teamcity); |
---|
[617c427] | 1248 | |
---|
[867952] | 1249 | # blockOpened ("init"); |
---|
[617c427] | 1250 | |
---|
| 1251 | # print ("TEAMCITY_BUILD_PROPERTIES_FILE: $ENV{TEAMCITY_BUILD_PROPERTIES_FILE}" ); |
---|
| 1252 | |
---|
[867952] | 1253 | # blockClosed ("init"); |
---|
[617c427] | 1254 | |
---|
| 1255 | |
---|
| 1256 | |
---|
[1a300b9] | 1257 | } |
---|
| 1258 | |
---|
| 1259 | |
---|
[b35b93] | 1260 | # Und Tschuess |
---|
| 1261 | exit $exit_code; |
---|
| 1262 | |
---|
| 1263 | |
---|