source: git/Tst/regress.cmd @ 44a1c2

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