tests/formats/num-out-compare.pl

   1 #! /usr/bin/perl -w
   2
   3 use strict;
   4 use Getopt::Long;
   5
   6 my $exact = 0;
   7 my $spss = 0;
   8 my $verbose = 0;
   9 Getopt::Long::Configure ("bundling");
  10 GetOptions ("e|exact!" => \$exact,
  11             "s|spss!" => \$spss,
  12             "v|verbose+" => \$verbose,
  13             "h|help" => sub { usage (0) })
  14   or usage (1);
  15
  16 sub usage {
  17     print "$0: compare expected and actual numeric formatting output\n";
  18     print "usage: $0 [OPTION...] EXPECTED ACTUAL\n";
  19     print "where EXPECTED is the file containing expected output\n";
  20     print "and ACTUAL is the file containing actual output.\n";
  21     print "Options:\n";
  22     print "  -e, --exact: Require numbers to be exactly equal.\n";
  23     print "               (By default, small differences are permitted.)\n";
  24     print "  -s, --spss: Ignore most SPSS formatting bugs in EXPECTED.\n";
  25     print "              (A few differences are not compensated)\n";
  26     print "  -v, --verbose: Use once to summarize errors and differences.\n";
  27     print "                 Use twice for details of differences.\n";
  28     exit (@_);
  29 }
  30
  31 open (EXPECTED, '<', $ARGV[0]) or die "$ARGV[0]: open: $!\n";
  32 open (ACTUAL, '<', $ARGV[1]) or die "$ARGV[1]: open: $!\n";
  33 my ($expr);
  34 my ($bad_round) = 0;
  35 my ($approximate) = 0;
  36 my ($spss_wtf1) = 0;
  37 my ($spss_wtf2) = 0;
  38 my ($lost_sign) = 0;
  39 my ($errors) = 0;
  40 while (defined (my $a = <EXPECTED>) && defined (my $b = <ACTUAL>)) {
  41     chomp $a;
  42     chomp $b;
  43     if ($a eq $b) {
  44         if ($a !~ /^\s*$/ && $a !~ /:/) {
  45             $expr = $a;
  46             $expr =~ s/\s*$//;
  47             $expr =~ s/^\s*//;
  48         }
  49     } else {
  50         my ($fmt, $a_out) = $a =~ /^ (.*): "(.*)"$/ or die;
  51         my ($b_fmt, $b_out) = $b =~ /^ (.*): "(.*)"$/ or die;
  52         die if $fmt ne $b_fmt;
  53         die if $a_out eq $b_out;
  54
  55         if (!$exact) {
  56             if (increment ($a_out) eq $b_out || increment ($b_out) eq $a_out) {
  57                 $approximate++;
  58                 next;
  59             }
  60         }
  61         if ($spss) {
  62             if ($a_out =~ /0.*0/ && $a_out !~ /[1-9]/) {
  63                 $bad_round++;
  64                 next;
  65             } elsif ($a_out =~ /\*/ && $a_out !~ /^\*+$/) {
  66                 $spss_wtf1++;
  67                 next;
  68             } elsif ($expr =~ /^-/
  69                      && $a_out =~ /^\*+$/
  70                      && $b_out =~ /-\d(\.\d*#*)?E[-+]\d\d\d/
  71                      && $fmt =~ /^E/) {
  72                 $spss_wtf2++;
  73                 next;
  74             } elsif ($expr =~ /^-/
  75                      && (($a_out !~ /-/ && $a_out =~ /[1-9]/ && $b_out =~ /-/)
  76                          || ($a_out =~ /^[0-9]+$/ && $b_out =~ /^\*+$/))) {
  77                 $lost_sign++;
  78                 next;
  79             }
  80         }
  81         print "$.: $expr in $fmt: expected \"$a_out\", got \"$b_out\"\n"
  82           if $verbose > 1;
  83         $errors++;
  84     }
  85 }
  86 if ($verbose) {
  87     print "$errors errors\n";
  88     if (!$exact) {
  89         print "$approximate approximate matches\n";
  90     }
  91     if ($spss) {
  92         print "$bad_round bad rounds\n";
  93         print "$spss_wtf1 SPSS WTF 1\n";
  94         print "$spss_wtf2 SPSS WTF 2\n";
  95         print "$lost_sign lost signs\n";
  96     }
  97 }
  98 exit ($errors > 0);
  99
 100 # Returns the argument value incremented by one unit in its final
 101 # decimal place.
 102 sub increment {
 103     local ($_) = @_;
 104     my ($last_digit, $i);
 105     for ($i = 0; $i < length $_; $i++) {
 106         my ($c) = substr ($_, $i, 1);
 107         last if ($c eq 'E');
 108         $last_digit = $i if $c =~ /[0-9]/;
 109     }
 110     return $_ if !defined $last_digit;
 111     for ($i = $last_digit; $i >= 0; $i--) {
 112         my ($c) = substr ($_, $i, 1);
 113         if ($c eq '9') {
 114             substr ($_, $i, 1) = '0';
 115         } elsif ($c =~ /[0-8]/) {
 116             substr ($_, $i, 1) = chr (ord ($c) + 1);
 117             last;
 118         }
 119     }
 120     $_ = "1$_" if $i < 0;
 121     return $_;
 122 }