tests/formats/num-out-cmp.pl

   1 use strict;
   2 use warnings 'all';
   3
   4 my (@prev) = ();
   5 our ($n) = 0;
   6 our ($suffix) = '';
   7 our ($prefix) = '';
   8 while (<>) {
   9     s/^ //;
  10     if (scalar (my (@line) = /^([A-Z]+)(\d+)([^"]+")( *)([^%"]*)(%?")$/) == 6) {
  11         if (defined ($prev[0])
  12             && $line[0] eq $prev[0]
  13             && $line[1] == $prev[1] + 1
  14             && $line[2] eq $prev[2]
  15             && $line[5] eq $prev[5]) {
  16             if ($line[3] eq " $prev[3]"
  17                 && $line[4] eq $prev[4]) {
  18                 flush_prefix ();
  19                 flush_suffix ();
  20                 $n++;
  21             } elsif ($line[3] eq $prev[3]
  22                      && length ($line[4]) == length ($prev[4]) + 1
  23                      && $prev[4] eq substr ($line[4], 0, length ($line[4]) - 1)) {
  24                 flush_n ();
  25                 flush_prefix ();
  26                 $suffix .= substr ($line[4], -1);
  27             } elsif ($line[3] eq $prev[3]
  28                      && $prev[4] eq substr ($line[4], 1)) {
  29                 flush_n ();
  30                 flush_suffix ();
  31                 $prefix .= substr ($line[4], 0, 1);
  32             } else {
  33                 flush ();
  34                 print $_;
  35             }
  36         } else {
  37             flush ();
  38             print $_;
  39         }
  40         @prev = @line;
  41     } else {
  42         flush ();
  43         print $_;
  44         @prev = ();
  45     }
  46 }
  47 flush ();
  48
  49 sub flush_suffix {
  50     if ($suffix ne '') {
  51         print "\$$suffix\n";
  52         $suffix = '';
  53     }
  54 }
  55
  56 sub flush_prefix {
  57     if ($prefix ne '') {
  58         print "^$prefix\n";
  59         $prefix = '';
  60     }
  61 }
  62
  63 sub flush_n {
  64     if ($n) {
  65         print "*$n\n";
  66         $n = 0;
  67     }
  68 }
  69
  70 sub flush {
  71     flush_prefix ();
  72     flush_suffix ();
  73     flush_n ();
  74 }