source: git/Tst/regress.cmd @ 6ce030f

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