source: git/Tst/regress.cmd @ 93e538

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