source: git/Tst/regress.cmd @ 5ed19c

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