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

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