source: git/Tst/regress.cmd @ 9d72fe

spielwiese
Last change on this file since 9d72fe was 31f293, checked in by Olaf Bachmann <obachman@…>, 24 years ago
* better stats git-svn-id: file:///usr/local/Singular/svn/trunk@4512 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100755
File size: 17.9 KB
Line 
1#!/usr/bin/perl
2
3#################################################################
4# $Id: regress.cmd,v 1.32 2000-08-14 11:27:06 obachman Exp $
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
10#################################################################
11#
12# usage
13#
14sub Usage
15{
16  print <<_EOM_
17Usage:
18regress.cmd    -- regress test of Singular
19  [-s <Singular>]   -- use <Singular> as executable to test
20  [-h]              -- print out help and exit
21  [-k]              -- keep all intermediate files
22  [-v num]          -- set verbosity to num (used range 0..3, default: 1)
23  [-g]              -- generate result (*.res.gz.uu) files, only
24  [-r [crit%[val]]] -- report if status differences [of crit] > val (in %)
25  [-c regexp]       -- when comparing results, version must match this regexp
26  [-e [crit%[val]]] -- throw error if status difference [of crit] > val (in %)
27  [-a [crit]]       -- add status results [of crit] to result file
28  [-m]              -- add status result for current version to result file
29  [-t]              -- compute and call mtrack at the end, no diffs
30  [file.lst]        -- read tst files from file.lst
31  [file.tst]        -- test Singular script file.tst
32_EOM_
33}
34
35#################################################################
36#
37# used programs
38#
39$sh="/bin/sh";
40$diff = "diff";
41$gunzip = "gunzip";
42$gzip = "gzip";
43$rm = "rm";
44$mv = "mv";
45$cp = "cp";
46$tr = "tr";
47$sed = "sed";
48$cat = "cat";
49$tee = "tee";
50$grep = "grep";
51
52sub mysystem
53{
54  local($call) = $_[0];
55  local($exit_status);
56
57  $call =~ s/"/\\"/g;
58  $call = "$sh -c \"$call\"";
59  print "$call\n" if ($verbosity > 1);
60  return (system $call);
61}
62
63sub mysystem_catch
64{
65  local($call) = $_[0];
66  local($output) = "";
67
68  $call = "$call > catch_$$";
69  & mysystem($call);
70
71  open(CATCH_FILE, "<catch_$$");
72  while (<CATCH_FILE>)
73  {
74    $output = $output.$_;
75  }
76  close(CATCH_FILE);
77  & mysystem("$rm -f catch_$$");
78  return $output;
79}
80
81$WINNT = 1 if (&mysystem("uname -a | $grep CYGWIN > /dev/null 2>&1") == 0);
82if ($WINNT)
83{
84  $uudecode = "uudeview.exe -i";
85}
86else
87{
88  $uuencode = "uuencode";
89  $uudecode = "uudecode";
90}
91
92#
93# flush stdout and stderr after every write
94#
95select(STDERR);
96$| = 1;
97select(STDOUT);
98$| = 1;
99
100#################################################################
101#
102# the default settings
103#
104$singularOptions = "--ticks-per-sec=100 -teqr12345678 --no-rc";
105$keep = "no";
106$verbosity = 1;
107$generate = "no";
108$exit_code = 0;
109chop($curr_dir=`pwd`);
110# singular -- use the one in curr directory or the one found above
111$ext=".exe" if ($WINNT);
112$singular = "$curr_dir/Singular$ext";
113if ( (! (-e $singular)) || (! (-x $singular)))
114{
115  $singular = $curr_dir."/../Singular$ext";
116}
117# sed scripts which are applied to res files before they are diff'ed
118$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'";
119# default value (in %) above which differences are reported on -r
120$report_val = 5;
121# default value (in %) above which differences cause an error on -e
122$error_val = 5;
123# default value in 1/100 seconds, above which time differences are reported
124$mintime_val = 100;
125$hostname = &mysystem_catch("hostname");
126chop $hostname;
127
128#################################################################
129#
130# auxiallary routines
131#
132
133sub GetSingularVersionDate
134{
135  &mysystem("$singular -t -v --execute=\"exit;\"> SingularVersionDate");
136  open(FD, "<SingularVersionDate");
137  while (<FD>)
138  {
139    $singular_uname = (/for\s+([^\s]*)\s+/ ? $1 : "uname");
140    $singular_version = (/version\s+([^\s]*)\s+/ ? $1 : "0-0-0");
141    $singular_date = (/\((.*)\)/ ? $1 : "1970010100");
142    $this_time = time;
143    last;
144  }
145  close(FD);
146}
147
148sub Set_withMP
149{
150  if (! $withMP)
151  {
152    $withMP = "no";
153    open(MP_TEST, ">MPTest");
154    print(MP_TEST "system(\"with\", \"MP\"); \$");
155    close(MP_TEST);
156    &mysystem("$singular -qt MPTest > withMPtest");
157    if (open(MP_TEST, "<withMPtest"))
158    {
159      $_ = <MP_TEST>;
160      $withMP = "yes" if (/^1/);
161      close(MP_TEST);
162    }
163    &mysystem("$rm -f withMPtest MPTest");
164  }
165}
166
167
168sub MPok
169{
170  local($root) = $_[0];
171
172  if (! open(TST_FILE, "<$root.tst"))
173  {
174    print (STDERR "Can not open $root.tst for reading\n");
175    return (0);
176  }
177  while (<TST_FILE>)
178  {
179    if (/\"MP.+:.*\"/)
180    {
181      &Set_withMP;
182      return (0) if ($withMP eq "no");
183    }
184  }
185  return (1);
186}
187
188sub Diff
189{
190  local($root) = $_[0];
191  local($exit_status);
192
193  # prepare the result files:
194  &mysystem("$cat $root.res | $tr -d '\\013' | $sed $sed_scripts > $root.res.cleaned");
195  &mysystem("$cat $root.new.res | $tr -d '\\013' | $sed $sed_scripts > $root.new.res.cleaned");
196
197  # doo the diff call
198  if ($verbosity > 0 && ! $WINNT)
199  {
200    $exit_status = &mysystem("$diff -w -b $root.res.cleaned $root.new.res.cleaned | $tee $root.diff");
201  }
202  else
203  {
204    $exit_status = &mysystem("$diff -w -b $root.res.cleaned $root.new.res.cleaned > $root.diff 2>&1");
205  }
206
207  # clean up time
208  &mysystem("$rm -f $root.res.cleaned $root.new.res.cleaned");
209
210  # there seems to be a bug here somewhere: even if diff reported
211  # differenceses and exited with status != 0, then system still
212  # returns exit status 0. Hence we manually need to find out whether
213  # or not differences were reported:
214  # iff diff-file exists and has non-zero size
215  $exit_status = $exit_status || (-e "$root.diff" && -s "$root.diff");
216
217  return($exit_status);
218}
219
220sub tst_status_check
221{
222  local($root) = $_[0];
223  local($line,$new_line,$prefix,$crit,$res,$new_res);
224  local($res_diff,$res_diff_pc,$res_diff_line);
225  my($exit_status, $reported) = (0, 0);
226  local($error_cause) = "";
227
228  open(RES_FILE, "<$root.stat") ||
229    return (1, "Can not open $root.stat \n");
230  open(NEW_RES_FILE, "<$root.new.stat") ||
231    return (1, "Can not open $root.new.stat \n");
232  open(STATUS_DIFF_FILE, ">$root.stat.sdiff") ||
233    return (1, "Can not open $root.stat.sdiff \n");
234
235  while (1)
236  {
237    while ($new_line = <NEW_RES_FILE>)
238    {
239      last if $new_line =~ /(\d+) >> (\w+) ::.*$hostname:(\d+)/ && $checks{$2};
240    }
241    last unless $new_line =~ /(\d+) >> (\w+) ::.*$hostname:(\d+)/;
242    $prefix = $1;
243    $crit = $2;
244    $new_res = $3;
245    next unless $new_res > $mintime_val;
246   
247    while ($line = <RES_FILE>)
248    {
249      last if $line =~ /$prefix >> $crit ::.*?$hostname:(\d+)/;
250    }
251    last unless $line =~ /$prefix >> $crit ::.*?$hostname:(\d+)/;
252    my $res_version;
253    $res = 0;
254
255    # search for smallest
256    while ($line =~ /([^\s]*)$hostname:(\d+)/g)
257    {
258      my $this_res = $2;
259      my $this_res_version = $1;
260      if ((!$res || $this_res <= $res) && (!$status_check_regexp  || $this_res_version =~ /$status_check_regexp/))
261      {
262        $res = $this_res;
263        $res_version = $this_res_version;
264      }
265    }
266    next unless $res;
267    $res_diff = $new_res - $res;
268    $res_diff_pc = int((($new_res / $res) - 1)*100);
269    $res_diff_line =
270      "$prefix >> $crit :: new:$new_res old:$res_version$res diff:$res_diff %:$res_diff_pc\n";
271    print STATUS_DIFF_FILE $res_diff_line;
272   
273    if ((defined($error{$crit}) &&  $error{$crit}<abs($res_diff_pc))
274        ||
275        (defined($report{$crit}) && $report{$crit}<abs($res_diff_pc)))
276    {
277      print "$prefix >> $crit :: new:$new_res old:$res diff:$res_diff %:$res_diff_pc\n"
278        if ($verbosity > 0);
279    }
280   
281    if ($exit_status == 0)
282    {
283      $exit_status = (defined($error{$crit})
284                      && $error{$crit} < abs($res_diff_pc));
285      $error_cause = "Status error for $crit at $prefix\n"
286        if ($exit_status);
287    }
288  }
289  close(RES_FILE);
290  close(NEW_RES_FILE);
291  close(STATUS_DIFF_FILE);
292  return ($exit_status, $error_cause);
293}
294
295sub tst_status_merge
296{
297  local($root) = $_[0];
298  local($line, $new_line, $crit, $res);
299
300  GetSingularVersionDate()
301    unless $singular_version;
302
303  if (! -e "$root.stat")
304  {
305    open(RES_FILE, ">$root.stat") ||
306      return (1, "Can not open $root.stat \n");
307    open(NEW_RES_FILE, "<$root.new.stat") ||
308      return (1, "Can not open $root.new.stat \n");
309
310    while (<NEW_RES_FILE>)
311    {
312      if (/(\d+) >> (\w+) :: /)
313      {
314        s/$hostname:(\d+)/$this_time:$singular_date:$singular_version:$singular_uname:$hostname:$1/g;
315        print RES_FILE $_;
316      }
317    }
318    close(RES_FILE);
319    close(NEW_RES_FILE);
320    return;
321  }
322
323  open(RES_FILE, "<$root.stat") ||
324    return (1, "Can not open $root.stat \n");
325  open(NEW_RES_FILE, "<$root.new.stat") ||
326    return (1, "Can not open $root.new.stat \n");
327  open(TEMP_FILE, ">$root.tmp.stat") ||
328    return (1, "Can not open $root.tmp.stat \n");
329
330  while (1)
331  {
332    while (($new_line = <NEW_RES_FILE>) && $new_line !~ /(\d+) >> (\w+) ::/){}
333    last unless $new_line =~ /(\d+) >> (\w+) ::.*$hostname:(\d+)/;
334    my $prefix = $1;
335    my $crit = $2;
336    my $new_res = "$this_time:$singular_date:$singular_version:$singular_uname:$hostname:$3";
337    while (($line = <RES_FILE>) && $line !~ /$prefix >> $crit ::/){}
338    unless ($line)
339    {
340      close(RES_FILE);
341      close(NEW_RES_FILE);
342      close(TEMP_FILE);
343      &mysystem("$rm $root.tmp.stat");
344      return (1, "Can not find '$prefix >> $crit' in $root.stat\n");
345    }
346    if ($merge_version)
347    {
348      $line =~ s/[^ ]*:$singular_version:$singular_uname:$hostname:\d+//g;
349      chop $line;
350      $line .= " $new_res\n";
351    }
352    else
353    {
354      chop $line;
355      $line .= " $new_res\n";
356    }
357    print TEMP_FILE $line;
358  }
359 
360  close(RES_FILE);
361  close(NEW_RES_FILE);
362  close(TEMP_FILE);
363  &mysystem("$mv -f $root.tmp.stat $root.stat");
364  &mysystem("$rm -f $root.new.stat $root.stat.sdiff") unless $keep eq "yes";
365  return ;
366}
367
368sub tst_check
369{
370  local($root) = $_[0];
371  local($system_call, $exit_status, $ignore_pattern, $error_cause);
372
373  print "--- $root\n" unless ($verbosity == 0);
374  # check for existence/readablity of tst and res file
375  if (! (-r "$root.tst"))
376  {
377    print (STDERR "Can not read $root.tst\n");
378    return (1);
379  }
380
381  # ignore MP stuff, if this singular does not have MP
382  if (! &MPok($root))
383  {
384    print "Warning: $root not tested: needs MP\n";
385    return (0);
386  }
387
388  # generate $root.res
389  if ($generate ne "yes" && ! $mtrack)
390  {
391    if ((-r "$root.res.gz.uu") && ! ( -z "$root.res.gz.uu"))
392    {
393      $exit_status = &mysystem("$uudecode $root.res.gz.uu > /dev/null 2>&1; $gunzip -f $root.res.gz");
394      if ($exit_status)
395      {
396        print (STDERR "Can not decode $root.res.gz.uu\n");
397        return ($exit_status);
398      }
399    }
400    elsif (! (-r "$root.res") || ( -z "$root.res"))
401    {
402      print (STDERR "Can not read $root.res[.gz.uu]\n");
403      return (1);
404    }
405  }
406
407  my $resfile = "$root.new.res";
408  $resfile = "$root.mtrack.res" if ($mtrack);
409  my $statfile = "$root.new.stat";
410  &mysystem("$rm -f $statfile");
411  if ($mtrack)
412  {
413    $system_call = "$cat $root.tst | sed -e 's/\\\\\$/LIB \"general.lib\"; killall(); killall(\"proc\");system(\"mtrack\", \"$root.mtrack.unused\"); \\\$/' | $singular $singularOptions ";
414    $system_call .= ($verbosity > 2 ? " | $tee " : " > ");
415    $system_call .= "$root.mtrack.res";
416    $system_call .= " 2>&1 " if ($verbosity <= 2);
417  }
418  else
419  {
420   
421    # prepare Singular run
422    if ($verbosity > 2 && !$WINNT)
423    {
424      $system_call = "$cat $root.tst | $singular --execute 'string tst_status_file=\"$statfile\";' $singularOptions | $tee $resfile";
425    }
426    else
427    {
428      $system_call = "$cat $root.tst | $singular --execute 'string tst_status_file=\"$statfile\";' $singularOptions > $resfile 2>&1";
429    }
430  }
431  # Go Singular, Go!
432  $exit_status = &mysystem($system_call);
433
434  if ($exit_status != 0)
435  {
436    $error_cause = "Singular call exited with status != 0";
437  }
438  else
439  {
440    # check for Segment fault in res file
441    $exit_status = ! (&mysystem("$grep \"Segment fault\" $resfile > /dev/null 2>&1"));
442
443    if ($exit_status)
444    {
445      $error_cause = "Segment fault";
446    }
447    elsif (! $mtrack)
448    {
449      &mysystem("$rm -f $root.diff");
450      if ($generate eq "yes")
451      {
452        &mysystem("$cp $resfile $root.res");
453      }
454      else
455      {
456        # call Diff
457        $exit_status = &Diff($root);
458        if ($exit_status)
459        {
460          $error_cause = "Differences in res files";
461        }
462        else
463        {
464          &mysystem("$rm -f $root.diff");
465        }
466      }
467    }
468  }
469
470  mysystem("mv tst_status.out $statfile")
471    if (! -e $statfile && -e "tst_status.out");
472
473  if (%checks && ! $exit_status && $generate ne "yes" && ! $mtrack)
474  {
475    if (-e "$statfile")
476    {
477      # do status checks
478      ($exit_status, $error_cause) = & tst_status_check($root);
479    }
480    else
481    {
482      print "Warning: no file $statfile\n";
483    }
484  }
485
486
487  # complain even if verbosity == 0
488  if ($exit_status)
489  {
490    print (STDERR "!!! $root : $error_cause\n");
491  }
492  else
493  {
494    unless ($mtrack)
495    {
496      #clean up
497      if ($generate eq "yes")
498      {
499        mysystem("$rm -f $root.stat") unless %merge;
500        ($exit_status, $error_cause) = tst_status_merge($root);
501        if (! $WINNT)
502        {
503          &mysystem("$gzip -cf $root.res | $uuencode $root.res.gz > $root.res.gz.uu");
504        }
505        else
506        {
507          # uuencode is broken under windows
508          print "Warning: Can not generate $root.res.gz.uu under Windows\n";
509        }
510      }
511      elsif (%merge)
512      {
513        ($exit_status, $error_cause) = & tst_status_merge($root);
514         
515        print (STDERR "Warning: Merge Problems: $error_cause\n")
516          if ($verbosity > 0 && $exit_status);
517      }
518    }
519    if ($keep ne "yes")
520    {
521      &mysystem("$rm -f tst_status.out $resfile $root.res $root.diff $root.new.stat");
522    }
523  }
524  # und tschuess
525  return ($exit_status);
526}
527
528
529#################################################################
530#
531# Main program
532#
533
534# process switches
535while ($ARGV[0] =~ /^-/)
536{
537  $_ = shift;
538  if (/^-s$/)
539  {
540    $singular = shift;
541  }
542  elsif (/^-h$/)
543  {
544    &Usage && exit (0);
545  }
546  elsif (/^-k$/)
547  {
548    $keep = "yes";
549  }
550  elsif (/^-g$/)
551  {
552    $generate = "yes";
553  }
554  elsif(/^-v$/)
555  {
556    $verbosity = shift;
557  }
558  elsif(/^-t$/)
559  {
560    $mtrack = 1;
561  }
562  elsif(/^-r$/)
563  {
564    $crit = "all";
565    $val = $report_val;
566    if ($ARGV[0] =~ /.*%.*/)
567    {
568      ($crit, $val) = split(/%/, shift);
569    }
570    elsif ($ARGV[0] &&
571           $ARGV[0] !~ /^-/ && $ARGV[0] !~ /.*\.tst/ && $ARGV[0] !~ /.*\.lst/)
572    {
573      $crit = shift;
574    }
575    if ($crit eq "all")
576    {
577      $report{"tst_memory_0"} = $val;
578      $report{"tst_memory_1"} = $val;
579      $report{"tst_memory_2"} = $val;
580      $report{"tst_timer"} = $val;
581      $report{"tst_timer_1"} = $val;
582      $checks{"tst_memory_0"} = 1;
583      $checks{"tst_memory_1"} = 1;
584      $checks{"tst_memory_2"} =  1;
585      $checks{"tst_timer"} =  1;
586      $checks{"tst_timer_1"} =  1;
587    }
588    else
589    {
590      $report{$crit} = $val;
591      $checks{$crit} = 1;
592    }
593  }
594  elsif(/^-e$/)
595  {
596    $crit = "all";
597    $val = $error_val;
598    if ($ARGV[0] =~ /.*%.*/)
599    {
600      ($crit, $val) = split(/%/, shift);
601    }
602    elsif ($ARGV[0] &&
603            $ARGV[0] !~ /^-/ && $ARGV[0] !~ /.*\.tst/ && $ARGV[0] !~ /.*\.lst/)
604    {
605      $crit = shift;
606    }
607    if ($crit eq "all")
608    {
609      $error{"tst_memory_0"} = $val;
610      $error{"tst_memory_1"} = $val;
611      $error{"tst_memory_2"} = $val;
612      $error{"tst_timer"} = $val;
613      $error{"tst_timer_1"} = $val;
614      $checks{"tst_memory_0"} = 1;
615      $checks{"tst_memory_1"} = 1;
616      $checks{"tst_memory_2"} =  1;
617      $checks{"tst_timer"} =  1;
618      $checks{"tst_timer_1"} =  1;
619    }
620    else
621    {
622      $error{$crit} = $val;
623      $checks{$crit} = 1;
624    }
625  }
626  elsif(/^-a/ || /^-m/)
627  {
628    $merge_version = 1 if /^-m/;
629    if ($ARGV[0] &&
630        $ARGV[0] !~ /^-/ && $ARGV[0] !~ /.*\.tst/ && $ARGV[0] !~ /.*\.lst/)
631    {
632      $crit = shift;
633      $merge{$crit} = 1;
634    }
635    else
636    {
637      $merge{"tst_memory_0"} = 1;
638      $merge{"tst_memory_1"} = 1;
639      $merge{"tst_memory_2"} =  1;
640      $merge{"tst_timer"} =  1;
641      $merge{"tst_timer_1"} =  1;
642    }
643  }
644  elsif (/^-c/)
645  {
646    $status_check_regexp = shift;
647  }
648  else
649  {
650    print (STDERR "Unrecognised option: $_\n") && &Usage && die;
651  }
652}
653
654# if no command line arguments are left, use regress.lst
655if ($#ARGV == -1)
656{
657  $ARGV[0] = "regress.lst";
658}
659
660# make sure $singular exists and is executable
661$singular = "$curr_dir/$singular" unless ($singular =~ /^\/.*/);
662
663if ( ! (-e $singular))
664{
665  $singular = "$singular$ext"   if ($WINNT && $singular !~ /.*$ext$/);
666}
667
668if ( ! (-e $singular))
669{
670  print (STDERR "Can not find $singular \n") && &Usage && die;
671}
672
673if (! (-x $singular) && (! WINNT))
674{
675  print (STDERR "Can not execute $singular \n") && &Usage && die;
676}
677if (-d $singular)
678{
679  print (STDERR "$singular is a directory\n") && &Usage && die;
680}
681
682
683# now do the work
684foreach (@ARGV)
685{
686
687  if ( /^(.*)\.([^\.\/]*)$/ )
688  {
689    $_ = $1;
690    $extension = $2;
691  }
692
693  if ( /^(.*)\/([^\/]*)$/ )
694  {
695    $path = $1;
696    $base = $2;
697    chdir($path);
698    print "cd $path\n" if ($verbosity > 1);
699  }
700  else
701  {
702    $path = "";
703    $base = $_;
704  }
705  $file = "$base.$extension";
706  chop ($tst_curr_dir = `pwd`);
707
708  if ($extension eq "tst")
709  {
710    $exit_code = &tst_check($base) || $exit_code;
711  }
712  elsif ($extension eq "lst")
713  {
714    if (! open(LST_FILE, "<$file"))
715    {
716      print (STDERR "Can not open $path/$file for reading\n");
717      $exit_code = 1;
718      next;
719    }
720    while (<LST_FILE>)
721    {
722      if (/^;/)          # ignore lines starting with ;
723      {
724        print unless ($verbosity == 0);
725        next;
726      }
727      next if (/^\s*$/); #ignore whitespaced lines
728      chop if (/\n$/);   #chop of \n
729
730      $_ = $1 if (/^(.*)\.([^\.\/]*)$/ ); # chop of extension
731      if ( /^(.*)\/([^\/]*)$/ )
732      {
733        $tst_path = $1;
734        $tst_base = $2;
735        chdir($tst_path);
736        print "cd $tst_path\n" if ($verbosity > 1);
737      }
738      else
739      {
740        $tst_path = "";
741        $tst_base = $_;
742      }
743      $tst_base =~ s/^\s*//;
744      $tst_base =~ s/(.*?)\s+.*/$1/;
745      $exit_code = &tst_check($tst_base) || $exit_code;
746
747      if ($tst_path ne "")
748      {
749        chdir($tst_curr_dir);
750        print "cd $tst_curr_dir\n" if ($verbosity > 1);
751      }
752    }
753    close (LST_FILE);
754  }
755  else
756  {
757    print (STDERR "Unknown extension of $_: Need extension lst or tst\n");
758    $exit_code = 1;
759  }
760  if ($path ne "")
761  {
762    chdir($curr_dir);
763    print "cd $curr_dir\n" if ($verbosity > 1);
764  }
765}
766
767# Und Tschuess
768exit $exit_code;
769
770
Note: See TracBrowser for help on using the repository browser.