source: git/Tst/regress.cmd @ 52f5a58

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