tests/formats/num-out-compare.pl

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