i18n-diff-auditor

   1 #!/usr/bin/perl -w
   2 use strict;
   3 use Carp;
   4 use Data::Dumper;
   5
   6 my @d = <>;
   7 unshift @d, "# dummy line to make line 1 index 1 in \@d\n";
   8
   9 our $i_last_l_ok = -1;
  10 our $count_i_last_l_ok;
  11
  12 sub l_ok ($) {
  13     my ($i) = @_;
  14
  15     if ($i == $i_last_l_ok) {
  16         confess $i if $count_i_last_l_ok++ > 50;
  17     } else {
  18         $count_i_last_l_ok = 0;
  19         $i_last_l_ok = $i;
  20     }
  21
  22     return unless $i < @d;
  23     $_ = $d[$i];
  24     #print STDERR "L $i\n";
  25     1;
  26 }
  27
  28 sub l ($) {
  29     my ($i) = @_;
  30     confess $i unless l_ok $i;
  31 };
  32
  33 our $perlop_text = <<'END'; # c&p from man perlop
  34            left        terms and list operators (leftward)
  35            left        ->
  36            nonassoc    ++ --
  37            right       **
  38            right       ! ~ \ and unary + and -
  39            left        =~ !~
  40            left        * / % x
  41            left        + - .
  42            left        << >>
  43            nonassoc    named unary operators
  44            nonassoc    < > <= >= lt gt le ge
  45            nonassoc    == != <=> eq ne cmp ~~
  46            left        &
  47            left        | ^
  48            left        &&
  49            left        || //
  50            nonassoc    ..  ...
  51            right       ?:
  52            right       = += -= *= etc. goto last next redo dump
  53            left        , =>
  54            nonassoc    list operators (rightward)
  55            right       not
  56            left        and
  57            left        or xor
  58
  59            **=    +=    *=    &=    &.=    <<=    &&=
  60                   -=    /=    |=    |.=    >>=    ||=
  61                   .=    %=    ^=    ^.=           //=
  62                         x=
  63 END
  64
  65 our $perlop_re;
  66
  67 sub prep_perlop () {
  68     my @ops;
  69     foreach (split /\n/, $perlop_text) {
  70         next unless m{\S};
  71         s{\s+$}{};
  72         s{^\s+}{};
  73         s{^(?: left | right | nonassoc ) \s+}{}x;
  74         next if m{^terms and list operators};
  75         next if m{^named unary};
  76         next if m{^list operators};
  77         s{ and unary.*}{};
  78         s{ etc\. }{ };
  79         s{\?\:}{ ? : };
  80         foreach my $op (split /\s+/) {
  81             next unless length $op;
  82             next if $op =~ m{^\w+$};
  83             $op =~ s/\W/\\$&/g;
  84             push @ops, $op;
  85         }
  86     }
  87     $perlop_re = '(?: '.(join ' | ', @ops).' )';
  88     $perlop_re = qr{$perlop_re}x;
  89     #print STDERR "$perlop_re\n";
  90 }
  91
  92 prep_perlop();
  93
  94 our ($ifilehead, $ihunkhead, $ichunkstart, $ichunkend);
  95 our ($before, $after);
  96
  97 sub semiparse ($) {
  98     ($_) = @_;
  99     my @o;
 100     for (;;) {
 101         s{^\s+}{};
 102         if (s{^[\$\@\%]?[_0-9a-zA-Z]+}{}) {
 103             push @o, { T => 'ident', L => $& };
 104         } elsif (s{^\<\<('?)([A-Z_]+)\1}{}) {
 105             my ($q,$d) = ($1,$2);
 106             push @o, { T => 'heredoc', Q => $q, Delim => $d };
 107             s{^
 108                 (             .* \n    )
 109                 ( (?: (?! $d) .* \n )* )
 110                           $d     \n
 111               }{ $1 }x or die "missing end of here doc $d\n";
 112             $o[$#o]{V} = $2;
 113         } elsif (s{^ (["'])( (?: [^\\'"]
 114                                | \\ [^"']
 115                                | (?! \1 ) [^"]
 116                               )*
 117                        \1 )}{}x) {
 118             my ($q,$v) = ($1,$2);
 119             push @o, { T => 'string', Q => $q, V => $v };
 120         } elsif (s{^$perlop_re|\;}{}) {
 121             push @o, { T => 'op', L => $& };
 122         } elsif (s/[[{(]//) {
 123             push @o, { T => 'bra', L => $& };
 124         } elsif (s/[]})]//) {
 125             push @o, { T => 'ket', L => $& };
 126         } elsif (s/^( [\$\@\%] )( \{ )//x) {
 127             push @o, { T => 'deref', L => $1 },
 128                      { T => 'bra',   L => $2 };
 129         } elsif (s/^ [\$\@\%] [^[^{] //x) {
 130             push @o, { T => 'specvar', L => $& };
 131         } elsif (!length) {
 132             last;
 133         } else {
 134             m{^.{0,10}};
 135             die "cannot tokenise \`$&'";
 136         }
 137     }
 138     return @o;
 139 }
 140
 141 sub analyse_chunk_core () {
 142     die "plain deletion\n" unless defined $after;
 143     die "plain insertion\n" unless defined $before;
 144     my @before = semiparse $before;
 145     my @after = semiparse $after;
 146     print Dumper($ichunkstart, $ichunkend, \@before, \@after);
 147     flush STDOUT;
 148 }
 149
 150 sub analyse_chunk () {
 151     for (;;) {
 152         eval { analyse_chunk_core(); };
 153         return unless length $@;
 154         if ($@ =~ m{^missing end of here doc (\S+)\n}) {
 155             # fudge this
 156             $before .= "\n$1\n";
 157             $after .= "\n$1\n";
 158             next;
 159         } else {
 160             die $@;
 161         }
 162     }
 163 }
 164
 165 for ($ifilehead = 0; l_ok $ifilehead; $ifilehead++) {
 166     m{^diff} or next;
 167     while (l_ok $ifilehead and m{^diff|^index|^---|^\Q+++\E}) { $ifilehead++ }
 168     $ihunkhead = $ifilehead;
 169     while (l_ok $ihunkhead) {
 170         m{^\@\@} or confess "$ihunkhead $_ ?";
 171         my $i = $ihunkhead + 1;
 172         for (; ; $i++) {
 173             if (!l_ok $i or m{^ } or m{^\@\@}) {
 174                 if (defined $ichunkstart) {
 175                     $ichunkend = $i;
 176                     eval { analyse_chunk(); 1; };
 177                     if (length $@) {
 178                         print Dumper('REPORT',
 179                                      $ichunkstart, $ichunkend,
 180                                      $before, $after,
 181                                      $@);
 182                     }
 183                     $ichunkstart = $ichunkend = $before = $after = undef;
 184                 }
 185                 l_ok $i or last;
 186                 m{^\@\@} and last;
 187             } elsif (m{^[-+]}) {
 188                 my $which = $& eq '-' ? \$before : \$after;
 189                 $ichunkstart //= $i;
 190                 $$which //= '';
 191                 $$which .= $';
 192             } else {
 193                 confess "$i $_ ?";
 194             }
 195         }
 196         $ichunkend = $i;
 197         $ihunkhead = $i;
 198     }
 199 }