#! /usr/bin/perl # The copyright notice and license are in the POD at the bottom. use strict; use warnings; use Locale::PO qw(); use Getopt::Long qw(GetOptions :config bundling gnu_compat); use autouse 'Pod::Usage' => qw(pod2usage); my $VERSION = "1.3"; sub show_version { print "check-accelerator-conflicts.pl $VERSION\n"; pod2usage({-verbose => 99, -sections => "COPYRIGHT AND LICENSE", -exitval => 0}); } my $Accelerator_tag; sub po_arrays_eq ($$) { my($left, $right) = @_; ref($left) eq "ARRAY" or return 0; ref($right) eq "ARRAY" or return 0; @$left == @$right or return 0; $left->[$_] eq $right->[$_] or return 0 foreach (0 .. $#$right); return 1; } sub check_po_file ($) { my($po_file_name) = @_; my %accelerators; my $warnings = 0; { my $pos = Locale::PO->load_file_asarray($po_file_name) or warn "$po_file_name: $!\n", return 2; foreach my $po (@$pos) { next if $po->fuzzy(); my $msgstr = $po->msgstr() or next; my($accelerator) = ($msgstr =~ /\Q$Accelerator_tag\E(.)/s) or next; $accelerator = uc($accelerator); my $automatic = $po->automatic() or next; my($contexts) = ($automatic =~ /^accelerator_context\(([^\)]*)\)/) or next; foreach my $context (split(/\s*,\s*/, $contexts)) { push @{$accelerators{$accelerator}{$context}}, $po; } } } foreach my $accelerator (sort keys %accelerators) { my $ctxhash = $accelerators{$accelerator}; foreach my $outer_ctxname (sort keys %$ctxhash) { # Cannot use "foreach my $pos" directly, because $pos # would then become an alias and change to 0 below. my $pos = $ctxhash->{$outer_ctxname}; if (ref($pos) eq "ARRAY" && @$pos > 1) { my @ctxnames_in_conflict; foreach my $ctxname (sort keys %$ctxhash) { if (po_arrays_eq($ctxhash->{$ctxname}, $pos)) { push @ctxnames_in_conflict, $ctxname; $ctxhash->{$ctxname} = 0; } } my $ctxnames_in_conflict = join(", ", map(qq("$_"), @ctxnames_in_conflict)); warn "$po_file_name: Accelerator conflict for \"$accelerator\" in $ctxnames_in_conflict:\n"; foreach my $po (@$pos) { my $lineno = $po->msgstr_begin_lineno(); my $msgstr = $po->msgstr(); # Get a string of unique characters in $msgstr, # preferring characters that start a word. my $displaystr = $msgstr; $displaystr =~ s/\Q$Accelerator_tag\E//g; my $suggestions = ""; foreach my $char ($displaystr =~ /\b(\w)/g, $displaystr =~ /(\w)/g) { $suggestions .= $char unless $suggestions =~ /\Q$char\E/i; } # But don't suggest unavailable characters. SUGGESTION: foreach my $char (split(//, $suggestions)) { foreach my $ctxname (@ctxnames_in_conflict) { $suggestions =~ s/\Q$char\E//, next SUGGESTION if exists $accelerators{uc($char)}{$ctxname}; } } warn "$po_file_name:$lineno: msgstr $msgstr\n"; if ($suggestions eq "") { warn "$po_file_name:$lineno: no suggestions :-(\n"; } else { warn "$po_file_name:$lineno: suggestions: $suggestions\n"; } } $warnings++; } # if found a conflict } # foreach context known for $accelerator } # foreach $accelerator return $warnings ? 1 : 0; } GetOptions("accelerator-tag=s" => sub { my($option, $value) = @_; die "Cannot use multiple --accelerator-tag options\n" if defined($Accelerator_tag); die "--accelerator-tag requires a single-character argument\n" if length($value) != 1; $Accelerator_tag = $value; }, "help" => sub { pod2usage({-verbose => 1, -exitval => 0}) }, "version" => \&show_version) or exit 2; $Accelerator_tag = "~" unless defined $Accelerator_tag; print(STDERR "$0: missing file operand\n"), exit 2 unless @ARGV; my $max_error = 0; foreach my $po_file_name (@ARGV) { my $error = check_po_file($po_file_name); $max_error = $error if $error > $max_error; } exit $max_error; __END__ =head1 NAME check-accelerator-conflicts.pl - Scan a PO file for conflicting accelerator keys. =head1 SYNOPSIS B [I