source: git/Tst/regress.cmd @ 8646b2

spielwiese
Last change on this file since 8646b2 was 8646b2, checked in by Olaf Bachmann <obachman@…>, 26 years ago
* Bug fix git-svn-id: file:///usr/local/Singular/svn/trunk@2332 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.22 1998-07-14 11:58:22 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  &mysystem("$rm -f tst_status.out");
352  if ($verbosity > 2 && !$WINNT)
353  {
354    $system_call = "$cat $root.tst | $singular $singularOptions | $tee $root.new.res";
355  }
356  else
357  {
358    $system_call = "$cat $root.tst | $singular $singularOptions > $root.new.res 2>&1";
359  }
360  # Go Singular, Go!
361  $exit_status = &mysystem($system_call);
362 
363  if ($exit_status != 0)
364  {
365    $error_cause = "Singular call exited with status != 0";
366  }
367  else
368  {
369    # check for Segment fault in res file
370    $exit_status = ! (&mysystem("$grep \"Segment fault\" $root.new.res > /dev/null 2>&1"));
371   
372    if ($exit_status)
373    {
374      $error_cause = "Segment fault";
375    }
376    else
377    {
378      &mysystem("$rm -f $root.diff");
379      if ($generate eq "yes")
380      {
381        &mysystem("$cp $root.new.res $root.res");
382      }
383      else
384      {
385        # call Diff
386        $exit_status = &Diff($root);
387        if ($exit_status)
388        {
389          $error_cause = "Differences in res files";
390        }
391      }
392    }
393  }
394
395  if (%checks && ! $exit_status && $generate ne "yes")
396  {
397    & mysystem("$cp -f tst_status.out $root.new.stat");
398    # do status checks
399    ($exit_status, $error_cause) = & tst_status_check($root);
400  }
401 
402 
403  # complain even if verbosity == 0
404  if ($exit_status)
405  {
406    print (STDERR "!!! $root : $error_cause\n");
407  }
408  else
409  {
410   
411    #clean up
412    if ($generate eq "yes")
413    {
414      & mysystem("$cp -f tst_status.out $root.stat");
415      if (! $WINNT)
416      {
417        &mysystem("$gzip -cf $root.res | $uuencode $root.res.gz > $root.res.gz.uu");
418      }
419      else
420      {
421        # uuencode is broken under windows
422        print "Warning: Can not generate $root.res.gz.uu under Windows\n";
423      }
424     
425    }
426    elsif (%merge)
427    {
428      if (! -r "$root.stat")
429      {
430        & mysystem("$cp -f tst_status.out $root.stat");
431      }
432      else
433      {
434        & mysystem("$cp -f tst_status.out $root.new.stat");
435        ($exit_status, $error_cause) = & tst_status_merge($root);
436
437        print (STDERR "Warning: Merge Problems: $error_cause\n")
438          if ($verbosity > 0 && $exit_status);
439      }
440    }
441
442    if ($keep ne "yes")
443    {
444      &mysystem("$rm -f tst_status.out $root.new.res $root.res $root.*diff $root.new.stat");
445    }
446  }
447 
448  # und tschuess
449  return ($exit_status);
450}
451
452
453#################################################################
454#
455# Main program
456#
457
458# process switches
459while ($ARGV[0] =~ /^-/)
460{
461  $_ = shift;
462  if (/^-s$/)
463  {
464    $singular = shift;
465  }
466  elsif (/^-h$/)
467  {
468    &Usage && exit (0);
469  }
470  elsif (/^-k$/)
471  {
472    $keep = "yes";
473  }
474  elsif (/^-g$/)
475  {
476    $generate = "yes";
477  }
478  elsif(/^-v$/)
479  {
480    $verbosity = shift;
481  }
482  elsif(/^-r$/)
483  {
484    $crit = "all";
485    $val = $report_val;
486    if ($ARGV[0] =~ /.*%.*/)
487    {
488      ($crit, $val) = split(/%/, shift);
489    }
490    elsif ($ARGV[0] && 
491           $ARGV[0] !~ /^-/ && $ARGV[0] !~ /.*\.tst/ && $ARGV[0] !~ /.*\.lst/)
492    {
493      $crit = shift;
494    }
495    if ($crit eq "all")
496    {
497      $report{"tst_memory_0"} = $val;
498      $report{"tst_memory_1"} = $val;
499      $report{"tst_memory_2"} = $val;
500      $report{"tst_timer"} = $val;
501      $report{"tst_timer_1"} = $val;
502      $checks{"tst_memory_0"} = 1;
503      $checks{"tst_memory_1"} = 1;
504      $checks{"tst_memory_2"} =  1;
505      $checks{"tst_timer"} =  1;
506      $checks{"tst_timer_1"} =  1;
507    }
508    else
509    {
510      $report{$crit} = $val;
511      $checks{$crit} = 1;
512    }
513  }
514  elsif(/^-e$/)
515  {
516    $crit = "all";
517    $val = $error_val;
518    if ($ARGV[0] =~ /.*%.*/)
519    {
520      ($crit, $val) = split(/%/, shift);
521    }
522    elsif ($ARGV[0] && 
523            $ARGV[0] !~ /^-/ && $ARGV[0] !~ /.*\.tst/ && $ARGV[0] !~ /.*\.lst/)
524    {
525      $crit = shift;
526    }
527    if ($crit eq "all")
528    {
529      $error{"tst_memory_0"} = $val;
530      $error{"tst_memory_1"} = $val;
531      $error{"tst_memory_2"} = $val;
532      $error{"tst_timer"} = $val;
533      $error{"tst_timer_1"} = $val;
534      $checks{"tst_memory_0"} = 1;
535      $checks{"tst_memory_1"} = 1;
536      $checks{"tst_memory_2"} =  1;
537      $checks{"tst_timer"} =  1;
538      $checks{"tst_timer_1"} =  1;
539    }
540    else
541    {
542      $error{$crit} = $val;
543      $checks{$crit} = 1;
544    }
545  }
546  elsif(/^-m$/)
547  {
548    if ($ARGV[0] &&
549        $ARGV[0] !~ /^-/ && $ARGV[0] !~ /.*\.tst/ && $ARGV[0] !~ /.*\.lst/)
550    {
551      $crit = shift;
552      $merge{$crit} = 1;
553    }
554    else
555    {
556      $merge{"tst_memory_0"} = 1;
557      $merge{"tst_memory_1"} = 1;
558      $merge{"tst_memory_2"} =  1;
559      $merge{"tst_timer"} =  1;
560      $merge{"tst_timer_1"} =  1;
561    }
562  }
563  else
564  {
565    print (STDERR "Unrecognised option: $_\n") && &Usage && die;
566  }
567}
568
569# if no command line arguments are left, use regress.lst
570if ($#ARGV == -1)
571{
572  $ARGV[0] = "regress.lst";
573}
574
575# make sure $singular exists and is executable
576$singular = "$curr_dir/$singular" unless ($singular =~ /^\/.*/);
577
578if ( ! (-e $singular))
579{
580  $singular = "$singular$ext"   if ($WINNT && $singular !~ /.*$ext$/);
581}
582
583if ( ! (-e $singular))
584{
585  print (STDERR "Can not find $singular \n") && &Usage && die;
586}
587
588if (! (-x $singular) && (! WINNT))
589{
590  print (STDERR "Can not execute $singular \n") && &Usage && die;
591}
592if (-d $singular)
593{
594  print (STDERR "$singular is a directory\n") && &Usage && die;
595}
596
597
598# now do the work
599foreach (@ARGV)
600{
601
602  if ( /^(.*)\.([^\.\/]*)$/ )
603  {
604    $_ = $1;
605    $extension = $2;
606  }
607
608  if ( /^(.*)\/([^\/]*)$/ )
609  {
610    $path = $1;
611    $base = $2;
612    chdir($path);
613    print "cd $path\n" if ($verbosity > 1);
614  }
615  else
616  {
617    $path = "";
618    $base = $_;
619  }
620  $file = "$base.$extension";
621  chop ($tst_curr_dir = `pwd`);
622 
623  if ($extension eq "tst")
624  {
625    $exit_code = &tst_check($base) || $exit_code;
626  }
627  elsif ($extension eq "lst")
628  {
629    if (! open(LST_FILE, "<$file"))
630    {
631      print (STDERR "Can not open $path/$file for reading\n");
632      $exit_code = 1;
633      next;
634    }
635    while (<LST_FILE>)
636    {
637      if (/^;/)          # ignore lines starting with ;
638      {
639        print unless ($verbosity == 0);
640        next;
641      }
642      next if (/^\s*$/); #ignore whitespaced lines
643      chop if (/\n$/);   #chop of \n
644     
645      $_ = $1 if (/^(.*)\.([^\.\/]*)$/ ); # chop of extension
646      if ( /^(.*)\/([^\/]*)$/ )
647      {
648        $tst_path = $1;
649        $tst_base = $2;
650        chdir($tst_path);
651        print "cd $tst_path\n" if ($verbosity > 1);
652      }
653      else
654      {
655        $tst_path = "";
656        $tst_base = $_;
657      }
658
659      $exit_code = &tst_check($tst_base) || $exit_code;
660
661      if ($tst_path ne "")
662      {
663        chdir($tst_curr_dir);
664        print "cd $tst_curr_dir\n" if ($verbosity > 1);
665      }
666    }
667    close (LST_FILE);
668  }
669  else
670  {
671    print (STDERR "Unknown extension of $_: Need extension lst or tst\n");
672    $exit_code = 1;
673  }
674  if ($path ne "")
675  {
676    chdir($curr_dir);
677    print "cd $curr_dir\n" if ($verbosity > 1);   
678  }
679}
680
681# Und Tschuess
682exit $exit_code;
683
684
Note: See TracBrowser for help on using the repository browser.