pintos-os.org Git - pspp/blob - tests/data/num-out-cmp.pl

   1 # Copyright (C) 2020  Free Software Foundation
   2
   3 # This program is free software: you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation, either version 3 of the License, or
   6 # (at your option) any later version.
   7
   8 # This program is distributed in the hope that it will be useful,
   9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 # GNU General Public License for more details.
  12
  13 # You should have received a copy of the GNU General Public License
  14 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15
  16 use strict;
  17 use warnings 'all';
  18
  19 my (@prev) = ();
  20 our ($n) = 0;
  21 our ($suffix) = '';
  22 our ($prefix) = '';
  23 while (<>) {
  24     s/^ //;
  25     if (scalar (my (@line) = /^([A-Z]+)(\d+)([^"]+")( *)([^%"]*)(%?")$/) == 6) {
  26         if (defined ($prev[0])
  27             && $line[0] eq $prev[0]
  28             && $line[1] == $prev[1] + 1
  29             && $line[2] eq $prev[2]
  30             && $line[5] eq $prev[5]) {
  31             if ($line[3] eq " $prev[3]"
  32                 && $line[4] eq $prev[4]) {
  33                 flush_prefix ();
  34                 flush_suffix ();
  35                 $n++;
  36             } elsif ($line[3] eq $prev[3]
  37                      && length ($line[4]) == length ($prev[4]) + 1
  38                      && $prev[4] eq substr ($line[4], 0, length ($line[4]) - 1)) {
  39                 flush_n ();
  40                 flush_prefix ();
  41                 $suffix .= substr ($line[4], -1);
  42             } elsif ($line[3] eq $prev[3]
  43                      && $prev[4] eq substr ($line[4], 1)) {
  44                 flush_n ();
  45                 flush_suffix ();
  46                 $prefix .= substr ($line[4], 0, 1);
  47             } else {
  48                 flush ();
  49                 print $_;
  50             }
  51         } else {
  52             flush ();
  53             print $_;
  54         }
  55         @prev = @line;
  56     } else {
  57         flush ();
  58         print $_;
  59         @prev = ();
  60     }
  61 }
  62 flush ();
  63
  64 sub flush_suffix {
  65     if ($suffix ne '') {
  66         print "\$$suffix\n";
  67         $suffix = '';
  68     }
  69 }
  70
  71 sub flush_prefix {
  72     if ($prefix ne '') {
  73         print "^$prefix\n";
  74         $prefix = '';
  75     }
  76 }
  77
  78 sub flush_n {
  79     if ($n) {
  80         print "*$n\n";
  81         $n = 0;
  82     }
  83 }
  84
  85 sub flush {
  86     flush_prefix ();
  87     flush_suffix ();
  88     flush_n ();
  89 }