source: git/Tst/regress.cmd @ 75f460

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