source: git/Tst/regress.cmd @ e2114af

spielwiese
Last change on this file since e2114af was e2114af, checked in by Olaf Bachmann <obachman@…>, 26 years ago
* incoporatred status checks git-svn-id: file:///usr/local/Singular/svn/trunk@2317 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.21 1998-07-13 09:14:54 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'";
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 = 10;
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) = 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.diff") ||
207    return (1, "Can not open $root.stat.diff \n");
208
209  $new_line = <NEW_RES_FILE>;
210  $line = <RES_FILE>;
211  while ($line && $new_line)
212  {
213    if ($line =~ /(\d+) >> (\w+) ::.*$hostname:(\d+)/ && $checks{$2})
214    {
215      $prefix = $1;
216      $crit = $2;
217      $res = $3;
218      if ($res > $mintime_val &&
219          $new_line =~ /$prefix >> $crit ::.*$hostname:(\d+)/)
220      {
221        $new_res = $1;
222        $res_diff = $new_res - $res;
223        $res_diff_pc = int((($new_res / $res) - 1)*100);
224        $res_diff_line =
225          "$prefix >> $crit :: new:$new_res old:$res diff:$res_diff %:$res_diff_pc";
226        print (STATUS_DIFF_FILE "$res_diff_line\n")
227          if ((defined($error{$crit}) &&  $error{$crit}<abs($res_diff_pc))
228              || 
229              (defined($report{$crit}) && $report{$crit}<abs($res_diff_pc)));
230       
231        print "$res_diff_line\n"
232          if ($verbosity > 0 &&
233              ((defined($error{$crit}) &&  $error{$crit}<abs($res_diff_pc))
234              || 
235              (defined($report{$crit}) && $report{$crit}<abs($res_diff_pc))));
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.diff")
253    if ($exit_status == 0 && $keep ne "yes");
254 
255  return ($exit_status, $error_cause);
256}
257
258sub tst_status_merge
259{
260  local($root) = $_[0];
261  local($line, $new_line, $crit, $res);
262 
263  open(RES_FILE, "<$root.stat") || 
264    return (1, "Can not open $root.stat \n");
265  open(NEW_RES_FILE, "<$root.new.stat") ||
266    return (1, "Can not open $root.new.stat \n");
267  open(TEMP_FILE, ">$root.tmp.stat") ||
268    return (1, "Can not open $root.tmp.stat \n");
269 
270  $new_line = <NEW_RES_FILE>;
271  $line = <RES_FILE>;
272  while ($line)
273  {
274    if ($new_line =~ /(\d+) >> (\w+) ::.*$hostname:(\d+)/ && $merge{$2})
275    {
276      $prefix = $1;
277      $crit = $2;
278      $new_res = $3;
279      if ($line =~ /$prefix >> $crit ::(.*)$hostname:(\d+)/)
280      {
281        $line =~ s/$hostname:$2/$hostname:$new_res/;
282        print(TEMP_FILE $line);
283      }
284      elsif ($line =~ /$prefix >> $crit ::(.*)/)
285      {
286        print(TEMP_FILE
287              "$prefix >> $crit :: $hostname:$new_res $1\n");
288      }
289      else
290      {
291        close(RES_FILE);
292        close(NEW_RES_FILE);
293        close(TEMP_FILE);
294        &mysystem("$rm $root.tmp.stat");
295        return (1, "Generate before doing a merge\n");
296      }
297    }
298    else
299    {
300      print(TEMP_FILE $line);   
301    }
302    $new_line = <NEW_RES_FILE>;
303    $line = <RES_FILE>;
304  }
305  close(RES_FILE);
306  close(NEW_RES_FILE);
307  close(TEMP_FILE);
308  &mysystem("$mv -f $root.tmp.stat $root.stat");
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")
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  # prepare Singular run
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      }
391    }
392  }
393
394  if (%checks && ! $exit_status && $generate ne "yes")
395  {
396    & mysystem("$cp -f tst_status.out $root.new.stat");
397    # do status checks
398    ($exit_status, $error_cause) = & tst_status_check($root);
399  }
400 
401 
402  # complain even if verbosity == 0
403  if ($exit_status)
404  {
405    print (STDERR "!!! $root : $error_cause\n");
406  }
407  else
408  {
409   
410    #clean up
411    if ($generate eq "yes")
412    {
413      & mysystem("$cp -f tst_status.out $root.stat");
414      if (! $WINNT)
415      {
416        &mysystem("$gzip -cf $root.res | $uuencode $root.res.gz > $root.res.gz.uu");
417      }
418      else
419      {
420        # uuencode is broken under windows
421        print "Warning: Can not generate $root.res.gz.uu under Windows\n";
422      }
423     
424    }
425    elsif (%merge)
426    {
427      if (! -r "$root.stat")
428      {
429        & mysystem("$cp -f tst_status.out $root.stat");
430      }
431      else
432      {
433        & mysystem("$cp -f tst_status.out $root.new.stat");
434        ($exit_status, $error_cause) = & tst_status_merge($root);
435
436        print (STDERR "Warning: Merge Problems: $error_cause\n")
437          if ($verbosity > 0 && $exit_status);
438      }
439    }
440
441    if ($keep ne "yes")
442    {
443      &mysystem("$rm -f tst_status.out $root.new.res $root.res $root.diff $root.new.stat");
444    }
445  }
446 
447  # und tschuess
448  return ($exit_status);
449}
450
451
452#################################################################
453#
454# Main program
455#
456
457# process switches
458while ($ARGV[0] =~ /^-/)
459{
460  $_ = shift;
461  if (/^-s$/)
462  {
463    $singular = shift;
464  }
465  elsif (/^-h$/)
466  {
467    &Usage && exit (0);
468  }
469  elsif (/^-k$/)
470  {
471    $keep = "yes";
472  }
473  elsif (/^-g$/)
474  {
475    $generate = "yes";
476  }
477  elsif(/^-v$/)
478  {
479    $verbosity = shift;
480  }
481  elsif(/^-r$/)
482  {
483    $crit = "all";
484    $val = $report_val;
485    if ($ARGV[0] =~ /.*%.*/)
486    {
487      ($crit, $val) = split(/%/, shift);
488    }
489    elsif ($ARGV[0] && 
490           $ARGV[0] !~ /^-/ && $ARGV[0] !~ /.*\.tst/ && $ARGV[0] !~ /.*\.lst/)
491    {
492      $crit = shift;
493    }
494    if ($crit eq "all")
495    {
496      $report{"tst_memory_0"} = $val;
497      $report{"tst_memory_1"} = $val;
498      $report{"tst_memory_2"} = $val;
499      $report{"tst_timer"} = $val;
500      $report{"tst_timer_1"} = $val;
501      $checks{"tst_memory_0"} = 1;
502      $checks{"tst_memory_1"} = 1;
503      $checks{"tst_memory_2"} =  1;
504      $checks{"tst_timer"} =  1;
505      $checks{"tst_timer_1"} =  1;
506    }
507    else
508    {
509      $report{$crit} = $val;
510      $checks{$crit} = 1;
511    }
512  }
513  elsif(/^-e$/)
514  {
515    $crit = "all";
516    $val = $error_val;
517    if ($ARGV[0] =~ /.*%.*/)
518    {
519      ($crit, $val) = split(/%/, shift);
520    }
521    elsif ($ARGV[0] && 
522            $ARGV[0] !~ /^-/ && $ARGV[0] !~ /.*\.tst/ && $ARGV[0] !~ /.*\.lst/)
523    {
524      $crit = shift;
525    }
526    if ($crit eq "all")
527    {
528      $error{"tst_memory_0"} = $val;
529      $error{"tst_memory_1"} = $val;
530      $error{"tst_memory_2"} = $val;
531      $error{"tst_timer"} = $val;
532      $error{"tst_timer_1"} = $val;
533      $checks{"tst_memory_0"} = 1;
534      $checks{"tst_memory_1"} = 1;
535      $checks{"tst_memory_2"} =  1;
536      $checks{"tst_timer"} =  1;
537      $checks{"tst_timer_1"} =  1;
538    }
539    else
540    {
541      $error{$crit} = $val;
542      $checks{$crit} = 1;
543    }
544  }
545  elsif(/^-m$/)
546  {
547    if ($ARGV[0] &&
548        $ARGV[0] !~ /^-/ && $ARGV[0] !~ /.*\.tst/ && $ARGV[0] !~ /.*\.lst/)
549    {
550      $crit = shift;
551      $merge{$crit} = 1;
552    }
553    else
554    {
555      $merge{"tst_memory_0"} = 1;
556      $merge{"tst_memory_1"} = 1;
557      $merge{"tst_memory_2"} =  1;
558      $merge{"tst_timer"} =  1;
559      $merge{"tst_timer_1"} =  1;
560    }
561  }
562  else
563  {
564    print (STDERR "Unrecognised option: $_\n") && &Usage && die;
565  }
566}
567
568# if no command line arguments are left, use regress.lst
569if ($#ARGV == -1)
570{
571  $ARGV[0] = "regress.lst";
572}
573
574# make sure $singular exists and is executable
575$singular = "$curr_dir/$singular" unless ($singular =~ /^\/.*/);
576
577if ( ! (-e $singular))
578{
579  $singular = "$singular$ext"   if ($WINNT && $singular !~ /.*$ext$/);
580}
581
582if ( ! (-e $singular))
583{
584  print (STDERR "Can not find $singular \n") && &Usage && die;
585}
586
587if (! (-x $singular) && (! WINNT))
588{
589  print (STDERR "Can not execute $singular \n") && &Usage && die;
590}
591if (-d $singular)
592{
593  print (STDERR "$singular is a directory\n") && &Usage && die;
594}
595
596
597# now do the work
598foreach (@ARGV)
599{
600
601  if ( /^(.*)\.([^\.\/]*)$/ )
602  {
603    $_ = $1;
604    $extension = $2;
605  }
606
607  if ( /^(.*)\/([^\/]*)$/ )
608  {
609    $path = $1;
610    $base = $2;
611    chdir($path);
612    print "cd $path\n" if ($verbosity > 1);
613  }
614  else
615  {
616    $path = "";
617    $base = $_;
618  }
619  $file = "$base.$extension";
620  chop ($tst_curr_dir = `pwd`);
621 
622  if ($extension eq "tst")
623  {
624    $exit_code = &tst_check($base) || $exit_code;
625  }
626  elsif ($extension eq "lst")
627  {
628    if (! open(LST_FILE, "<$file"))
629    {
630      print (STDERR "Can not open $path/$file for reading\n");
631      $exit_code = 1;
632      next;
633    }
634    while (<LST_FILE>)
635    {
636      if (/^;/)          # ignore lines starting with ;
637      {
638        print unless ($verbosity == 0);
639        next;
640      }
641      next if (/^\s*$/); #ignore whitespaced lines
642      chop if (/\n$/);   #chop of \n
643     
644      $_ = $1 if (/^(.*)\.([^\.\/]*)$/ ); # chop of extension
645      if ( /^(.*)\/([^\/]*)$/ )
646      {
647        $tst_path = $1;
648        $tst_base = $2;
649        chdir($tst_path);
650        print "cd $tst_path\n" if ($verbosity > 1);
651      }
652      else
653      {
654        $tst_path = "";
655        $tst_base = $_;
656      }
657
658      $exit_code = &tst_check($tst_base) || $exit_code;
659
660      if ($tst_path ne "")
661      {
662        chdir($tst_curr_dir);
663        print "cd $tst_curr_dir\n" if ($verbosity > 1);
664      }
665    }
666    close (LST_FILE);
667  }
668  else
669  {
670    print (STDERR "Unknown extension of $_: Need extension lst or tst\n");
671    $exit_code = 1;
672  }
673  if ($path ne "")
674  {
675    chdir($curr_dir);
676    print "cd $curr_dir\n" if ($verbosity > 1);   
677  }
678}
679
680# Und Tschuess
681exit $exit_code;
682
683
Note: See TracBrowser for help on using the repository browser.