source: git/Tst/regress.cmd @ 010b3f

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