source: git/Tst/regress.cmd @ 4a7108c

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