source: git/Tst/regress.cmd @ f50a14

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