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, $ifirsthunkhead);
  95 our ($ihunkhead, $ihunkend);
  96 our ($ichunkstart, $ichunkend);
  97 our ($before, $after);
  98
  99 sub semiparse ($) {
 100     ($_) = @_;
 101     my @o;
 102     # entries contain
 103     #   T     type
 104     #   E     exact input text (does not contain here doc contents)
 105     #   P     something to print in messages
 106     #   V     value, only for: heredoc string
 107     #   Q     quote characcter, only for: heredoc string
 108     for (;;) {
 109         s{^\s+}{};
 110         if (s{^[\$\@\%]?[_0-9a-zA-Z]+}{}) {
 111             push @o, { T => 'ident', E => $&, P => $& };
 112         } elsif (s{^\<\<(['"]?)([A-Z_]+)\1}{}) {
 113             my ($q,$d) = ($1,$2);
 114             $q //= '"';
 115             push @o, { T => 'heredoc', Q => $q, Delim => $d,
 116                        E => $&, P => "<<$q$d..." };
 117             s{^
 118                 (             .* \n    )
 119                 ( (?: (?! $d) .* \n )* )
 120                           $d     \n
 121               }{ $1 }x or die "missing end of here doc $d\n";
 122             $o[$#o]{V} = $2;
 123         } elsif (s{^ (["'])( (?: [^\\'"]
 124                                | \\ [^"']
 125                                | (?! \1 ) [^"]
 126                               )*
 127                        \1 )}{}x) {
 128             my ($q,$v) = ($1,$2);
 129             push @o, { T => 'string', E => $&, P => "$q-string",
 130                        Q => $q, V => $v};
 131         } elsif (s{^$perlop_re|\;}{}) {
 132             push @o, { T => 'op', E => $&, P => $& };
 133         } elsif (s/[[{(]//) {
 134             push @o, { T => 'bra', E => $&, P => $& };
 135         } elsif (s/[]})]//) {
 136             push @o, { T => 'ket', E => $&, P => $& };
 137         } elsif (s/^( [\$\@\%] )( \{ )//x) {
 138             push @o, { T => 'deref', E => $1, P => $1 },
 139                      { T => 'bra',   E => $2, P => $2 };
 140         } elsif (s/^ [\$\@\%] [^[^{] //x) {
 141             push @o, { T => 'specvar', E => $&, P => $& };
 142         } elsif (!length) {
 143             last;
 144         } else {
 145             m{^.{0,10}};
 146             die "cannot tokenise \`$&'";
 147         }
 148     }
 149     # coalesce concatenated strings
 150     return @o;
 151 }
 152
 153 sub analyse_chunk_core () {
 154     die "plain deletion\n" unless defined $after;
 155     die "plain insertion\n" unless defined $before;
 156     my @xs = semiparse $before;
 157     my @ys = semiparse $after;
 158     my $next_something = sub {
 159         my ($ary,$var,$what) = @_;
 160         die "ran out of $what\n" unless @$ary;
 161         $$var = shift @$ary;
 162     };
 163     my ($x,$y);
 164     my $next_x = sub { $next_something->(\@xs, \$x, 'before'); };
 165     my $next_y = sub { $next_something->(\@ys, \$y, 'after' ); };
 166     my $is_string = sub { $_[0]{T} =~ m/heredoc|string/; };
 167     for (;;) {
 168         last unless @xs or @ys;
 169         $next_x->();
 170         $next_y->();
 171         next if $x->{E} eq $y->{E};
 172         my $string_changed;
 173         my $ye = $y->{E};
 174         if ($ye eq '__' or $ye eq 'f_') {
 175             $next_y->();
 176             die "__ on non-string $y->{P}\n"     unless $is_string->($y);
 177             die "__ on was non-string $y->{P}\n" unless $is_string->($x);
 178             if ($y->{Q} ne "'") {
 179                 die "var subst in new string\n"
 180                     if $y->{V} =~ m{(?<!\\) [\$\@]};
 181             }
 182             eval {
 183                 die "__ string changed\n"       unless $y->{V} eq $x->{V};
 184                 die "__ string quote changed\n" unless $y->{Q} eq $x->{Q};
 185             };
 186             $string_changed = $@;
 187         }
 188         if ($ye eq '__') {
 189             $_ = $y->{V};
 190             die "percent $& in __ ' string\n" if m{\%};
 191             die $string_changed if length $string_changed;
 192             next;
 193         }
 194         if ($ye eq 'f_') {
 195             my $fmt = $y->{V};
 196             die "no percent in _f string\n" unless $fmt =~ m{\%};
 197             next unless $string_changed;
 198             die "f_ old string '-quoted\n" if length $x->{V};
 199             my $xs = $x->{V};
 200             my $exactly = sub {
 201                 my ($lit) = @_;
 202                 my $xl = substr($xs, 0, length($lit));
 203                 die "exactly mismatch in $lit\n" unless $xl eq $lit;
 204                 $xs = substr($xs, length($lit));
 205             };
 206             for (;;) {
 207                 if ($fmt !~ m{\%[^\%]}) {
 208                     $exactly->($fmt);
 209                     $fmt = '';
 210                     last;
 211                 }
 212                 $exactly->($`);
 213                 $fmt = $';
 214                 if ($& eq '%%') { $exactly->('%'); next; }
 215                 elsif ($& ne '%s') { die "unhandled %-subst $&\n"; }
 216                 $next_y->();
 217                 die "expected comma, got $y->{P}\n" unless $y->{E} eq ',';
 218                 if ($xs =~ m{^\@}) {
 219                     $next_y->();
 220                     die "\@... => not string" unless $is_string->($y);
 221                     die "\@... => $y->{P}" if $y->{Q} ne '"';
 222                     $exactly->($y->{V});
 223                     next;
 224                 }
 225                 my $bras = 0;
 226                 for (;;) {
 227                     if (!$bras and !@ys) {
 228                         last;
 229                     }
 230                     $next_y->();
 231                     if (!$bras and
 232                         (grep { $y->{E} eq $_ } qw( or xor and not ; : )
 233                          or $y->{T} eq 'ket'
 234                         )) {
 235                         unshift @ys, $y;
 236                         last;
 237                     }
 238                     $xs =~ s{^\s+}{};
 239                     $exactly->($y->{E});
 240                     if ($y->{T} eq 'bra' or $y->{L} eq '?') {
 241                         $bras++;
 242                     } elsif ($y->{T} eq 'ket' or $y->{L} eq ':') {
 243                         die "too many kets at $y->{L}\n" unless $bras;
 244                         $bras--;
 245                     }
 246                 }
 247             }
 248             next;
 249         }
 250         die "mismatch $x->{P} => $y->{P}\n";
 251     }
 252 }
 253
 254 sub analyse_chunk () {
 255     for (;;) {
 256         eval { analyse_chunk_core(); };
 257         return unless length $@;
 258         if ($@ =~ m{^missing end of here doc (\S+)\n}) {
 259             # fudge this
 260             $before .= "\n$1\n";
 261             $after .= "\n$1\n";
 262             next;
 263         } else {
 264             die $@;
 265         }
 266     }
 267 }
 268
 269 our @report;
 270 our $last_filehead = -1;
 271
 272 sub report_on_hunk () {
 273     return unless @report;
 274     if ($last_filehead != $ifilehead) {
 275         foreach (my $i=$ifilehead; $i<$ifirsthunkhead; $i++) {
 276             print $d[$i];
 277         }
 278         $last_filehead = $ifilehead;
 279     }
 280     my $dummy_r = { S => (scalar @d)+1, E => (scalar @d)+1 };
 281     my $r;
 282     for (my $i=$ihunkhead; ; $i++) {
 283         for (;;) {
 284             $r //= shift @report;
 285             $r //= $dummy_r;
 286             last if $i < $r->{E};
 287             confess unless $r->{Done} == 03;
 288             $r = undef;
 289         }
 290
 291         last unless $i<$ihunkend;
 292
 293         if ($i == $r->{S}) {
 294             print "!! $r->{M}";
 295             $r->{Done} |= 01;
 296         }
 297         if ($i >= $r->{S}) {
 298             print "!";
 299             $r->{Done} |= 02;
 300         } else {
 301             print " ";
 302         }
 303         print $d[$i];
 304     }
 305     confess unless $r = $dummy_r;
 306 }
 307
 308 for ($ifilehead = 0; l_ok $ifilehead; $ifilehead++) {
 309     m{^diff} or next;
 310     $ifirsthunkhead = $ifilehead;
 311     while (l_ok $ifirsthunkhead and
 312            m{^diff|^index|^---|^\Q+++\E}) {
 313         $ifirsthunkhead++
 314     }
 315     $ihunkhead = $ifirsthunkhead;
 316     while (l_ok $ihunkhead) {
 317         m{^\@\@} or confess "$ihunkhead $_ ?";
 318         my $i = $ihunkhead + 1;
 319         for (; ; $i++) {
 320             if (!l_ok $i or m{^ } or m{^\@\@}) {
 321                 if (defined $ichunkstart) {
 322                     $ichunkend = $i;
 323                     eval { analyse_chunk(); 1; };
 324                     if (length $@) {
 325                         push @report, { M => $@,
 326                                         S => $ichunkstart,
 327                                         E => $ichunkend };
 328                     }
 329                     $ichunkstart = $ichunkend = $before = $after = undef;
 330                 }
 331                 l_ok $i or last;
 332                 m{^\@\@} and last;
 333             } elsif (m{^[-+]}) {
 334                 my $which = $& eq '-' ? \$before : \$after;
 335                 $ichunkstart //= $i;
 336                 $$which //= '';
 337                 $$which .= $';
 338             } else {
 339                 confess "$i $_ ?";
 340             }
 341         }
 342         $ihunkend = $i;
 343         report_on_hunk();
 344         $ichunkend = $i;
 345         $ihunkhead = $i;
 346     }
 347 }