chiark / gitweb /
documentation style: "appropriate configuration" as a mass noun
[dgit.git] / i18n-diff-auditor
1 #!/usr/bin/perl -w
2 #
3 # i18n-diff-auditor
4 # Copyright (C)2018 Ian Jackson
5 # GPLv3+, NO WARRANTY, see below.
6 #
7 #
8 # Usage:
9 #  something like this
10 #  git-log -n1 -p | ./i18n-diff-auditor -D 2>&1 |less -j10 +/'^!.*'
11 #
12 # -D is for debug.  Currently only one level.
13 #
14 # Output is the relevant diff hunks, with each line prepended with
15 # space for ok lines and ! for questionable ones, and with relevant
16 # diff lines prepended with lines starting !! (and lines starting #
17 # for debug output), so ovrall:
18 #
19 #   !! <message>   reasoning for subsequent questionable diff line(s)
20 #   !+             diff line found to be questionable
21 #   !-             diff line found to be questionable
22 #    @@@ etc.      diff furniture
23 #    +             diff line checked and ok
24 #    -             diff line checked and ok
25 #   # <stuff>      debug output (normally precedes relevant output)
26 #
27 # Changes are generally marked as ok if they correspond to a known
28 # intended code change pattern.  (That includes changing error calls
29 # to different error calls.)  If they don't correspond to any known
30 # pattern, they are "questionable" and the first thing that doesn't
31 # match the most common pattern is reported.
32 #
33 # Might be useful for projects other than dgit, provided it uses
34 # the same gettext aliases (__ f_ i_) and similar error calls
35 # (die, confess, fail).
36 #
37 #
38 # This program is free software: you can redistribute it and/or modify
39 # it under the terms of the GNU General Public License as published by
40 # the Free Software Foundation, either version 3 of the License, or
41 # (at your option) any later version.
42 #
43 # This program is distributed in the hope that it will be useful,
44 # but WITHOUT ANY WARRANTY; without even the implied warranty of
45 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
46 # GNU General Public License for more details.
47 #
48 # You should have received a copy of the GNU General Public License
49 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
50
51 use strict;
52 use Carp;
53 use Data::Dumper;
54 use Getopt::Long;
55
56 our $debug = 0;
57 GetOptions("debug|D+" => \$debug
58            );
59
60 our @debug;
61 sub debug ($$) {
62     my ($i,$s) = @_;
63     push @{ $debug[$i] }, $s if $debug;
64 }
65
66 my @d = <>;
67 unshift @d, "# dummy line to make line 1 index 1 in \@d\n";
68
69 our $i_last_l_ok = -1;
70 our $count_i_last_l_ok;
71
72 sub l_ok ($) {
73     my ($i) = @_;
74
75     if ($i == $i_last_l_ok) {
76         confess $i if $count_i_last_l_ok++ > 50;
77     } else {
78         $count_i_last_l_ok = 0;
79         $i_last_l_ok = $i;
80     }
81
82     return unless $i < @d;
83     $_ = $d[$i];
84     #print STDERR "L $i\n";
85     1;
86 }
87
88 sub l ($) {
89     my ($i) = @_;
90     confess $i unless l_ok $i;
91 };
92
93 our $perlop_text = <<'END'; # c&p from man perlop
94            left        terms and list operators (leftward)
95            left        ->
96            nonassoc    ++ --
97            right       **
98            right       ! ~ \ and unary + and -
99            left        =~ !~
100            left        * / % x
101            left        + - .
102            left        << >>
103            nonassoc    named unary operators
104            nonassoc    < > <= >= lt gt le ge
105            nonassoc    == != <=> eq ne cmp ~~
106            left        &
107            left        | ^
108            left        &&
109            left        || //
110            nonassoc    ..  ...
111            right       ?:
112            right       = += -= *= etc. goto last next redo dump
113            left        , =>
114            nonassoc    list operators (rightward)
115            right       not
116            left        and
117            left        or xor
118
119            **=    +=    *=    &=    &.=    <<=    &&=
120                   -=    /=    |=    |.=    >>=    ||=
121                   .=    %=    ^=    ^.=           //=
122                         x=
123 END
124
125 our $perlop_re;
126
127 sub prep_perlop () {
128     my @ops;
129     foreach (split /\n/, $perlop_text) {
130         next unless m{\S};
131         s{\s+$}{};
132         s{^\s+}{};
133         s{^(?: left | right | nonassoc ) \s+}{}x;
134         next if m{^terms and list operators};
135         next if m{^named unary};
136         next if m{^list operators};
137         s{ and unary.*}{};
138         s{ etc\. }{ };
139         s{\?\:}{ ? : };
140         foreach my $op (split /\s+/) {
141             next unless length $op;
142             next if $op =~ m{^\w+$};
143             $op =~ s/\W/\\$&/g;
144             push @ops, $op;
145         }
146     }
147     $perlop_re = '(?: '.(join ' | ', @ops).' )';
148     $perlop_re = qr{$perlop_re}x;
149     #print STDERR "$perlop_re\n";
150 }
151
152 prep_perlop();
153
154 our ($ifilehead, $ifirsthunkhead);
155 our ($ihunkhead, $ihunkend);
156 our ($ichunkstart, $ichunkend);
157 our ($before, $after);
158
159 sub is_string ($) { $_[0]{T} =~ m/heredoc|string/; }
160 sub is_trans ($) { grep { $_[0]{E} eq $_ } qw(__ f_ i_); }
161
162 sub qp ($) {
163     my ($p) = @_;
164     $p =~ s{\\}{\\\\}g;
165     $p =~ s{\'}{\\'}g;
166     $p =~ s{\n}{\\n}g;
167     $p =~ s{\t}{\\t}g;
168     return "'$p'";
169 };
170
171 sub semiparse ($) {
172     ($_) = @_;
173     my @o;
174     #my $in = $_;
175     # entries contain
176     #   T     type
177     #   E     exact input text (does not contain here doc contents)
178     #   P     something to print in messages
179     #   V     value, only for: heredoc string
180     #   Q     quote characcter, only for: heredoc string
181     for (;;) {
182         s{^\s+}{};
183         if (s{^[\$\@\%]?[_0-9a-zA-Z]+}{}) {
184             push @o, { T => 'ident', E => $&, P => $& };
185         } elsif (s{^\<\<(['"]?)([A-Z_]+)\1}{}) {
186             my ($q,$d) = ($1,$2);
187             $q ||= '"';
188             push @o, { T => 'heredoc', Q => $q, Delim => $d,
189                        E => $&, P => "<<$q$d$q" };
190             if (s{^
191                     (                 .* \n     )
192                     ( (?: (?! $d \n ) .* \n )*? )
193                               $d         \n
194                  }{ $1 }xe) {
195                 $o[$#o]{V} = $2;
196             } else {
197                 m{^.*\n} or confess;
198                 $_ = $&;
199                 $o[$#o]{V} = $';
200                 $o[$#o]{Invented} = 1;
201             }
202         } elsif (s{^ (["'])( (?: [^\\'"]
203                                | \\ [^"']
204                                | (?! \1 ) [^"]
205                               )*
206                        ) \1 }{}x) {
207             my ($q,$v) = ($1,$2);
208             push @o, { T => 'string', E => $&, P => "$q$q",
209                        Q => $q, V => $v};
210         } elsif (s{^$perlop_re|^\;}{}) {
211             push @o, { T => 'op', E => $&, P => $& };
212         } elsif (s/^[[{(]//) {
213             push @o, { T => 'bra', E => $&, P => $& };
214         } elsif (s/^[]})]//) {
215             push @o, { T => 'ket', E => $&, P => $& };
216         } elsif (s/^( [\$\@\%] )( \{ )//x) {
217             push @o, { T => 'deref', E => $1, P => $1 },
218                      { T => 'bra',   E => $2, P => $2 };
219         } elsif (s/^ [\$\@\%] [^[^{] //x) {
220             push @o, { T => 'specvar', E => $&, P => $& };
221         } elsif (!length) {
222             last;
223         } elsif (s{^\#.*\n}{}) {
224         } else {
225             m{^.{0,10}};
226             die "cannot tokenise \`$&'";
227         }
228     }
229     for (my $i=0; $i+2 < @o; $i++) {
230         next unless $o[$i+1]{E} eq '.';
231         my @inputs = @o[$i, $i+2];
232         #print STDERR Dumper(\@inputs);
233         next if grep { !is_string($_) } @inputs;
234         my $q = $inputs[0]{Q};
235         next if grep { $_->{Q} ne $q } @inputs;
236         next if grep { $_->{Invented} } @inputs;
237         my $new = { T => 'joinedstrings',
238                     E => (join '.', map { $_->{E} } @inputs),
239                     P => (join '.', map { $_->{P} } @inputs),
240                     V => (join '',  map { $_->{V} } @inputs),
241                     Q => $q,
242                   };
243         @o = (@o[0..$i-1], $new, @o[$i+3..$#o]);
244         $i--; # counteracts $i++
245     }
246     debug $ichunkstart, "semiparsed: ".join ' ', map { $_->{P} } @o;
247     # debug $ichunkstart, "semiparsed V: ".join ' ', map { defined $_->{V} ? ">$_->{V}<" : '-' } @o;
248     return @o;
249 }           
250
251 our @analysed_x;
252 our @analysed_y;
253
254 sub analyse_chunk_core () {
255     $before //= '';
256     die "plain deletion\n" unless defined $after;
257     my @xs = semiparse $before;
258     my @ys = semiparse $after;
259     @analysed_x = @analysed_y = ();
260     my $next_something = sub {
261         my ($ary,$anal,$var,$what) = @_;
262         die "ran out of $what\n" unless @$ary;
263         my $r = shift @$ary;
264         push @$anal, $r->{P};
265         $$var = $r;
266     };
267     my ($x,$y);
268     my $next_x = sub { $next_something->(\@xs, \@analysed_x, \$x, 'before'); };
269     my $next_y = sub { $next_something->(\@ys, \@analysed_y, \$y, 'after' ); };
270     our @y_expect_suffix = ();
271   ANALYSE:
272     for (;;) {
273         while (my $e = shift @y_expect_suffix) {
274             $next_y->();
275             $y->{E} eq $e
276                 or die "suffix mismatch, expected $e got $y->{E}\n";
277         }
278         last unless @xs or @ys;
279         $next_x->();
280         $next_y->();
281         next if $x->{E} eq $y->{E};
282         next if $x->{E} eq 'sprintf' and $y->{E} eq 'f_';
283         next if $x->{E} eq 'die'     and $y->{E} eq 'confess';
284         next if $x->{E} eq 'die'     and $y->{E} eq 'fail';
285         foreach my $with_fh (qw(0 1)) {
286             next unless $x->{E} eq 'printf';
287             next unless $y->{E} eq 'print';
288             next unless @xs >= $with_fh;
289             next unless @ys >  $with_fh;
290             if ($with_fh) {
291                 next unless $xs[0]{E} eq $ys[0]{E};
292                 next unless
293                     $xs[0]{E} =~ m{^[A-Z]+$} or
294                     $xs[0]{T} eq 'ident' && $xs[0]{E} =~ m{^\$};
295             }
296             next unless $ys[$with_fh]{E} eq 'f_';
297             # yay!
298             $next_x->() if $with_fh;
299             $next_y->() if $with_fh;
300             $next_y->(); # f_
301             next ANALYSE;
302         }
303         if ($y->{E} eq '+'
304             and @ys >= 3
305             and $ys[0]{E} eq '('
306             and is_trans($ys[1])) {
307             $next_y->(); # (
308             $next_y->(); # __ f_ i_
309             @y_expect_suffix = ')';
310         } elsif ($y->{E} eq '('
311             and @ys > 2
312             and is_trans($ys[0])
313             and @analysed_y
314             and (grep { $_ eq $analysed_y[-1] } (qw( => [ { ? : . ),
315                                                  '(', ',') )) {
316             $next_y->(); # __ f_ i_
317             @y_expect_suffix = ')';
318         }
319         my $string_changed;
320         my $ye = $y->{E};
321         if (is_trans($y)) {
322             $next_y->();
323             die "__ on non-string $y->{P}\n"     unless is_string($y);
324             die "__ on was non-string $x->{P}\n" unless is_string($x);
325             if ($y->{Q} ne "'") {
326                 die "var subst in new string\n"
327                     if $y->{V} =~ m{(?<!\\) [\$\@]};
328             }
329             eval {
330                 die "__ string changed\n"       unless $y->{V} eq $x->{V};
331                 die "__ string quote changed\n" unless $y->{Q} eq $x->{Q};
332             };
333             $string_changed = $@;
334         }
335         if ($ye eq '__') {
336             $_ = $y->{V};
337             die "percent $& in __ ' string\n" if m{\%};
338             die $string_changed if length $string_changed;
339             next;
340         }
341         if ($ye eq 'i_') {
342             die $string_changed if length $string_changed;
343             next;
344         }
345         if ($ye eq 'f_') {
346             my $fmt = $y->{V};
347             die "no percent in f_ string\n" unless $fmt =~ m{\%};
348             next unless $string_changed;
349             die "f_ old string '-quoted\n" if $x->{Q} ne '"';
350             my $xs = $x->{V};
351             my $exactly = sub {
352                 my ($lit, $what) = @_;
353                 my $xl = substr($xs, 0, length($lit));
354                 if ($xl ne $lit) {
355                     debug $ichunkstart, "not exactly x: ..".qp($xs);
356                     debug $ichunkstart, "not exactly y:   ".qp($lit);
357                     my $next = @ys ? $ys[0]{P} : '(end)';
358                     die "string contents mismatch near $what before $next\n";
359                 }
360                 $xs = substr($xs, length($lit));
361             };
362             for (;;) {
363                 #print STDERR Dumper($fmt, $xs, \@xs, @ys);
364                 if ($fmt !~ m{\%[^\%]}) {
365                     $exactly->($fmt, '(tail)');
366                     $fmt = '';
367                     die "text deleted from end of string: ".qp($xs)."\n"
368                         if length $xs;
369                     last;
370                 }
371                 $exactly->($`, '(literal)');
372                 $fmt = $';
373                 if ($& eq '%%') { $exactly->('%', '%%'); next; }
374                 elsif ($& ne '%s') { die "unhandled %-subst $&\n"; }
375                 $next_y->();
376                 die "expected comma, got $y->{P}\n" unless $y->{E} eq ',';
377                 if (!length $fmt and
378                     !length $xs and
379                     @xs and
380                     $xs[0]{E} eq '.') {
381                     # X has   "<earlier>" .                <something>
382                     # Y has   "<earlier>%s" [other args] , <something>
383                     $next_x->(); # eat the '.'
384                     next;
385                 }
386                 if ($xs =~ m{^\@}) {
387                     $next_y->();
388                     die "\@... => not string" unless is_string($y);
389                     die "\@... => $y->{P}" if $y->{Q} ne '"';
390                     $exactly->($y->{V}, $y->{P});
391                     next;
392                 }
393                 my $bras = 0;
394                 for (;;) {
395                     if (!$bras and !@ys) {
396                         last;
397                     }
398                     $next_y->();
399                     if (!$bras and
400                         (grep { $y->{E} eq $_ } qw( or xor and not ; :
401                                                     if unless while when )
402                          or $y->{E} eq ','
403                          or $y->{T} eq 'ket'
404                         )) {
405                         # lookahead shows close of containing scope
406                         # or lower precedence operator
407                         unshift @ys, $y;
408                         pop @analysed_y;
409                         last;
410                     }
411                     $xs =~ s{^\s+}{} if $bras;
412                     if (is_string($y) and $y->{Q} eq '"') {
413                         $exactly->($y->{V}, $y->{P});
414                         next;
415                     }
416                     $exactly->($y->{E}, $y->{P});
417                     if ($y->{T} eq 'bra' or $y->{E} eq '?') {
418                         $bras++;
419                     } elsif ($y->{T} eq 'ket' or $y->{E} eq ':') {
420                         die "too many kets at $y->{E}\n" unless $bras;
421                         $bras--;
422                     }
423                 }
424             }
425             next;
426         }
427         die "mismatch $x->{P} => $y->{P}\n";
428     }
429 }
430
431 sub analyse_chunk () {
432     for (;;) {
433         eval { analyse_chunk_core(); };
434         return unless length $@;
435         if ($@ =~ m{^missing end of here doc (\S+)\n}) {
436             # fudge this
437             # (this never happens now, but in the future we might
438             # want this code again eg to try adding to the chunk)
439             $before .= "\n$1\n";
440             $after .= "\n$1\n";
441             next;
442         } else {
443             die $@;
444         }
445     }
446 }
447
448 our @report;
449 our $last_filehead = -1;
450
451 sub report_on_hunk () {
452     return unless @report;
453     if ($last_filehead != $ifilehead) {
454         foreach (my $i=$ifilehead; $i<$ifirsthunkhead; $i++) {
455             print $d[$i];
456         }
457         $last_filehead = $ifilehead;
458     }
459     my $dummy_r = { S => (scalar @d)+1, E => (scalar @d)+1 };
460     my $r;
461     for (my $i=$ihunkhead; ; $i++) {
462         for (;;) {
463             $r //= shift @report;
464             $r //= $dummy_r;
465             last if $i < $r->{E};
466             confess unless $r->{Done} == 03;
467             $r = undef;
468         }
469
470         last unless $i<$ihunkend;
471
472         foreach my $ds (@{ $debug[$i] }) {
473             print "# $ds\n";
474         }
475
476         if ($i == $r->{S}) {
477             print "!! $r->{M}";
478             $r->{Done} |= 01;
479         }
480         if ($i >= $r->{S}) {
481             print "!";
482             $r->{Done} |= 02;
483         } else {
484             print " ";
485         }
486         print $d[$i];
487     }
488     confess unless $r = $dummy_r;
489 }
490
491 for ($ifilehead = 0; l_ok $ifilehead; $ifilehead++) {
492     m{^diff} or next;
493     $ifirsthunkhead = $ifilehead;
494     while (l_ok $ifirsthunkhead and
495            m{^diff|^index|^---|^\Q+++\E}) {
496         $ifirsthunkhead++
497     }
498     $ihunkhead = $ifirsthunkhead;
499     while (l_ok $ihunkhead) {
500         m{^\@\@} or confess "$ihunkhead $_ ?";
501         my $i = $ihunkhead + 1;
502         for (; ; $i++) {
503             if (!l_ok $i or m{^ } or m{^\@\@}) {
504                 if (defined $ichunkstart) {
505                     $ichunkend = $i;
506                     eval { analyse_chunk(); 1; };
507                     if (length $@) {
508                         debug $ichunkstart, "done x: @analysed_x";
509                         debug $ichunkstart, "done y: @analysed_y";
510                         push @report, { M => $@,
511                                         S => $ichunkstart,
512                                         E => $ichunkend };
513                     }
514                     $ichunkstart = $ichunkend = $before = $after = undef;
515                 }
516                 l_ok $i or last;
517                 m{^\@\@} and last;
518             } elsif (m{^[-+]}) {
519                 my $which = $& eq '-' ? \$before : \$after;
520                 $ichunkstart //= $i;
521                 $$which //= '';
522                 $$which .= $';
523             } else {
524                 confess "$i $_ ?";
525             }
526         }
527         $ihunkend = $i;
528         report_on_hunk();
529         $ichunkend = $i;
530         $ihunkhead = $i;
531     }
532 }