source: git/Tst/regress.cmd @ 451d118

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