source: git/Tst/regress.cmd @ dfe914

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