linux/glibc/check-locale

   1 #!/usr/bin/perl
   2 #
   3 # Author: Petter Reinholdtsen
   4 # Date: 2004-06-01
   5 #
   6 # Test the content of GNU libc locales, detect some common errors.
   7
   8 use warnings;
   9 use strict;
  10
  11 use vars qw($locale $warncount $errcount);
  12
  13 sub uxx_to_utf8 {
  14     my $line = shift;
  15     $line =~ s/<U([0-9A-Za-z]{4})>/pack('U',hex($1))/ge;
  16     return $line;
  17 }
  18
  19 sub error {
  20     my $msg = shift;
  21     $errcount++;
  22     print "error: $locale: $msg\n";
  23 }
  24
  25 sub warning {
  26     my $msg = shift;
  27     $warncount++;
  28     print "warning: $locale: $msg\n";
  29 }
  30
  31 sub check_lc_identification {
  32     my @lines = @_;
  33     for my $line (@lines) {
  34         if ($line =~ m/^category\s+(\S+)$/) {
  35             warning "LC_IDENTIFICATION: missing quotes around category standard ref: $1"
  36                 if ($1 !~ m/\".+\"/);
  37         }
  38         if ($line =~ m/^email\s+(\S+)\s*$/) {
  39             my $email = $1;
  40             warning "LC_IDENTIFICATION: obsolete email: $email"
  41                 if ($email =~ m/"?bug-glibc\@gnu.org"?/);
  42         }
  43     }
  44 }
  45 sub check_lc_paper {
  46     my @lines = @_;
  47     my $height = undef;
  48     my $width = undef;
  49     for (@lines) {
  50         $height = $1 if (m/^height\s*(\d+)\s*$/);
  51         $width = $1 if (m/^width\s*(\d+)\s*$/);
  52         return if (m/^copy\s+/); # Nothing to check
  53     }
  54
  55     if (!defined $width || defined $height) {
  56 #       warning "LC_PAPER: Missing height or width.";
  57         return;
  58     }
  59
  60     if (210 == $width && 297 == $height) {      # ISO A4
  61     } elsif (216 == $width && 279 == $height) { # US Letter
  62     } else {
  63         warning "LC_PAPER: unknown paper size.";
  64     }
  65 }
  66
  67 sub check_lc_measurement {
  68     my @lines = @_;
  69     for my $line (@lines) {
  70         if ($line =~ m/^\s*(measurement)\s+(\S+)\s*$/) {
  71             my $value = $2;
  72             if (defined $value && $value !~ m/^\d+$/) {
  73                 warning "LC_MEASUREMENT: measurements should be number 1 or 2.";
  74             } elsif  ($value < 1 && 2 < $value) {
  75                 warning "LC_MEASUREMENT: measurements should be 1 or 2.";
  76             }
  77         }
  78     }
  79 }
  80
  81 sub check_lc_numeric {
  82     my @lines = @_;
  83     for my $line (@lines) {
  84         next if ($line eq "LC_NUMERIC" || $line eq "END LC_NUMERIC");
  85         next if ($line =~ m/^$/);
  86         if ($line =~ m/^\s*(grouping)\s+(\S+)\s*$/) {
  87             my $value = $2;
  88             if ($value =~ m/^-?\d+$/) {
  89                 # Only digits (or - digits)
  90                 if ( $value < 1 && $value != -1) {
  91                     warning "LC_NUMERIC: grouping should positive or -1: $value";
  92                 }
  93             } else {
  94                 if (defined $value && $value !~ m/\d+;\d+/) {
  95                     warning "LC_NUMERIC: grouping should use ; as separator: $value";
  96                 }
  97             }
  98         } elsif ($line =~ m/^\s*(decimal_point)\s+(\S+)\s*$/) {
  99         } elsif ($line =~ m/^\s*(thousands_sep)\s+(\S+)\s*$/) {
 100             my $sep = $2;
 101 #           print "P: '$sep'\n";
 102             warning "LC_NUMERIC: Unusual thousands_sep '$sep' [".
 103                 uxx_to_utf8($sep)."]"
 104                 unless (grep { $_ eq $sep; }  ('"<U0020>"',
 105                                                '"<U0027>"',
 106                                                '"<U002C>"',
 107                                                '"<U002E>"',
 108                                                '"<U00A0>"',
 109                                                '""'));
 110         } elsif ($line =~ m/^\s*(copy)\s+(\S+)\s*$/) {
 111         } else {
 112             warning "LC_NUMERIC: Unknown keyword '$line'";
 113         }
 114     }
 115 }
 116
 117 sub check_lc_messages {
 118     my @lines = @_;
 119     for (@lines) {
 120         if (m/^\s*(yesexpr|noexpr)\s+(.+)$/) {
 121             my $type  = $1;
 122             my $regex = uxx_to_utf8($2);
 123             unless ($regex =~ m/^"\^/) {
 124                 error "LC_MESSAGES: $type missing '^' prefix: $regex";
 125             }
 126             unless ($regex =~ m/\[.+\]|\(.+\)/) {
 127                 error "LC_MESSAGES: $type missing '[.+]|(.+)' content: $regex";
 128             }
 129             if ($regex =~ m/\.\*"$/) {
 130                 warning "LC_MESSAGES: $type have '.*' postfix: $regex";
 131             }
 132             if ($regex =~ m/[0-9]/) {
 133                 warning "LC_MESSAGES: $type have numbers in regex: $regex";
 134             }
 135             if ($type eq "yesexpr" && ($regex !~ m/y/ ||
 136                                        $regex !~ m/Y/)) {
 137                 warning "LC_MESSAGES: $type missing 'yY' in content: $regex";
 138             }
 139             if ($type eq "noexpr" && ($regex !~ m/n/ ||
 140                                       $regex !~ m/N/)) {
 141                 warning "LC_MESSAGES: $type missing 'nN' in content: $regex";
 142             }
 143         }
 144     }
 145 }
 146
 147 my $section;
 148 my %sections;
 149 my @blocks = ();
 150 for my $filename (@ARGV) {
 151     open (FILE, "<$filename") || die "Unable to read $filename";
 152     $locale = $filename;
 153     my $buf = undef;
 154     my @lines;
 155     %sections = ();
 156     while (<FILE>) {
 157         chomp;
 158         s/%.*$//; # Remove comments
 159         s/\#.*$//;
 160         if (m%^(.+)/$%) {
 161             $buf .= $1;
 162             next;
 163         }
 164         if (! defined $buf) {
 165             $buf = $_;
 166         } else {
 167             $buf .= $_;
 168         }
 169         if (!$section && m/^(LC_.*)\s*$/) {
 170             $section = $1;
 171             @lines = ();
 172             #print "Found section $section\n";
 173         }
 174         push(@lines, $buf);
 175         if (m/^END (LC_.+)\s*$/) {
 176             if (exists $sections{$section}) {
 177                 warning "duplicate section $section";
 178             }
 179             push(@blocks, $section);
 180             $sections{$section} = [@lines];
 181             $section = "";
 182             #print "Stored section $section\n";
 183         }
 184         undef $buf;
 185     }
 186     close(FILE);
 187
 188     check_order(@blocks);
 189     check_lc_identification(@{$sections{'LC_IDENTIFICATION'}});
 190     check_lc_messages(@{$sections{'LC_MESSAGES'}});
 191     check_lc_numeric(@{$sections{'LC_NUMERIC'}});
 192     check_lc_paper(@{$sections{'LC_PAPER'}});
 193     check_lc_measurement(@{$sections{'LC_MEASUREMENT'}});
 194 }
 195 sub check_order {
 196     my @blocks = @_;
 197     my @order= qw(LC_IDENTIFICATION
 198                   LC_CTYPE
 199                   LC_COLLATE
 200                   LC_MONETARY
 201                   LC_NUMERIC
 202                   LC_TIME
 203                   LC_MESSAGES
 204                   LC_PAPER
 205                   LC_NAME
 206                   LC_ADDRESS
 207                   LC_TELEPHONE
 208                   LC_MEASUREMENT);
 209     my $pos = 0;
 210     for my $section (@blocks) {
 211         if ($section eq $order[$pos]) {
 212             $pos++;
 213         } else {
 214             $pos = 0;
 215             $pos++ while ($order[$pos] ne $section);
 216             warning "$section: not following section $order[$pos-1]";
 217         }
 218     }
 219 }