languages/validate.pl

   1 #! /usr/bin/perl -w
   2
   3 use strict;
   4 use warnings;
   5 use vars qw($field_re %lang %escapes);
   6 use FileHandle ();
   7
   8 $| = 1;
   9
  10 $field_re = qr/%.*?[diouxXeEfFgGaAcspn%]/;
  11
  12 %escapes = (
  13             '"' => '"',
  14             'n' => "\n",
  15             '\\' => "\\"
  16            );
  17
  18 sub split_format ($$$) {
  19   my ($language, $key, $format) = @_;
  20   my (@fields, @sorted, $indexed, $idx);
  21
  22   # C indexes things from argument 1.
  23   $fields[0] = { type => 'dummy' };
  24
  25   # Parse each format field in the string.
  26   while ($format =~ /($field_re)/g) {
  27     my $field = $1;
  28     next if substr($field, -1) eq '%';
  29     if ($field =~ /^%(\d+\$)(#?0?-? ?\+?)(\*\d+\$|\d*)(.\*\d+\$|\.\d+)?((?:hh?|ll?|L|j|z|t)?.)$/) {
  30       if (not defined $indexed) {
  31         $indexed = 1;
  32       } elsif (not $indexed) {
  33         print "MISMATCH: ${language} ${key}, mix of indexed and unindexed fields\n";
  34         return ();
  35       }
  36       my $res = {};
  37       $res->{index} = substr($1, 0, -1);
  38       $res->{flags} = $2;
  39       $res->{width} = $3;
  40       $res->{precision} = $4;
  41       $res->{type} = $5;
  42       $res->{width_idx} = $1
  43         if $res->{width} and $res->{width} =~ /^\*\d+\$$/;
  44       $res->{prec_idx} = $1
  45         if $res->{precision} and $res->{precision} =~ /^.\*(\d+)\$$/;
  46       push @fields, $res;
  47     } elsif ($field =~ /^%(#?0?-? ?\+?)(\*|\d*)(.\*|\.\d+)?((?:hh?|ll?|L|j|z|t)?.)$/) {
  48       if (not defined $indexed) {
  49         $indexed = 0;
  50         $idx = 1;
  51       } elsif ($indexed) {
  52         print "MISMATCH: ${language} ${key}, mix of indexed and unindexed fields\n";
  53         return ();
  54       }
  55       my $res = {};
  56       $res->{flags} = $1;
  57       $res->{width} = $2;
  58       $res->{precision} = $3;
  59       $res->{type} = $4;
  60       $res->{width_idx} = $idx++
  61         if $res->{width} and $res->{width} eq '*';
  62       $res->{prec_idx} = $idx++
  63         if $res->{precision} and $res->{precision} eq '.*';
  64       $res->{index} = $idx++;
  65       push @fields, $res;
  66     } else {
  67       print "Unparsed field ${language} ${key}: $field\n";
  68       next;
  69     }
  70   }
  71
  72   # Go through and make sure they are in fully sorted order, with
  73   # precision arguments marked properly.
  74   foreach my $field (@fields) {
  75     next if $field->{type} eq 'dummy' or $field->{type} eq 'width' or $field->{type} eq 'precision';
  76     my $idx = $field->{index};
  77
  78     # Check for conflicts with this field.
  79     if (my $old = $sorted[$idx]) {
  80       if ($old->{type} ne $field->{type}) {
  81         print "MISMATCH ${key}: ${language} refers to param $idx as both type ".$old->{type}." and ".$field->{type}.".\n";
  82         next;
  83       }
  84       if ($old->{precision} or $field->{precision}) {
  85         if (exists($old->{prec_idx}) != exists($field->{prec_idx})) {
  86           print "MISMATCH ${key}: ${language} has param $idx with and without a precision argument.\n";
  87           next;
  88         } elsif ($old->{prec_idx} != $field->{prec_idx}) {
  89           print "MISMATCH ${key}: ${language} has param $idx with different precision arguments.\n";
  90           next;
  91         }
  92       }
  93       if ($old->{width} or $field->{width}) {
  94         if (exists($old->{width_idx}) != exists($field->{width_idx})) {
  95           print "MISMATCH ${key}: ${language} has param $idx with and without width argument.\n";
  96         } elsif ($old->{width_idx} != $field->{width_idx}) {
  97           print "MISMATCH ${key}: ${language} has param $idx with different width arguments.\n";
  98         }
  99       }
 100     }
 101     $sorted[$idx] = $field;
 102
 103     if (exists($field->{width_idx})) {
 104       my $width_idx = $field->{width_idx};
 105       if (my $old = $sorted[$width_idx]) {
 106         if ($old->{type} ne 'width') {
 107           print "MISMATCH ${key}: ${language} refers to param $idx as both type ".$old->{type}." and type width.\n";
 108           next;
 109         }
 110       }
 111       $sorted[$width_idx] = { type => 'width' };
 112     }
 113
 114     if (exists($field->{prec_idx})) {
 115       my $prec_idx = $field->{prec_idx};
 116       # Check for conflicts with this field's precision argument.
 117       if (my $old = $sorted[$prec_idx]) {
 118         if ($old->{type} ne 'precision') {
 119           print "MISMATCH ${key}: ${language} refers to param $idx as both type ".$old->{type}." and type precision.\n";
 120           next;
 121         }
 122       }
 123       $sorted[$prec_idx] = { type => 'precision' };
 124     }
 125   }
 126
 127   return @sorted;
 128 }
 129
 130 sub compare_formats ($$$$) {
 131   my ($language, $key, $orig_fmt, $new_fmt) = @_;
 132
 133   my @orig_fields = split_format('C', $key, $orig_fmt);
 134   my @new_fields = split_format($language, $key, $new_fmt);
 135   if (scalar(@orig_fields) != scalar(@new_fields)) {
 136     print "MISMATCH ${key}: C has ".scalar(@orig_fields)." fields, ${language} has ".scalar(@new_fields)."\n";
 137     return;
 138   }
 139   for (my $x = 1; $x <= $#orig_fields; $x++) {
 140     my $orig = $orig_fields[$x];
 141     my $new = $new_fields[$x];
 142     if (not exists $orig->{type}) {
 143       print "MISMATCH ${key}: C has no type for format $x!\n";
 144     } elsif (not exists $new->{type}) {
 145       print "MISMATCH ${key}: ${language} has no type for format $x!\n";
 146     } if ($orig->{type} ne $new->{type}) {
 147       print "MISMATCH ${key}: C refers to argument $x as type ".$orig->{type}.", ${language} as type ".$new->{type}.".\n";
 148       next;
 149     }
 150     if ($orig->{width} or $new->{width}) {
 151       if (not exists ($orig->{width_idx}) and not exists($new->{width_idx})) {
 152         # both used fixed widths: no problem
 153       } elsif (exists($orig->{width_idx}) and not exists($new->{width_idx})) {
 154         print "MISMATCH ${key}: C has a width argument for format $x, ${language} does not.\n";
 155       } elsif (not exists($orig->{width_idx}) and exists($new->{width_idx})) {
 156         print "MISMATCH ${key}: ${language} has a width argument for format $x, C does not.\n";
 157       } elsif ($orig->{width_idx} != $new->{width_idx}) {
 158         print "MISMATCH ${key}: C and ${language} disagree on width argument for format $x.\n";
 159       }
 160     }
 161     if ($orig->{precision} or $new->{precision}) {
 162       if (not exists($orig->{prec_idx}) and not exists($new->{prec_idx})) {
 163         # both used fixed precisions: no problem
 164       } elsif (exists($orig->{prec_idx}) and not exists($new->{prec_idx})) {
 165         print "MISMATCH ${key}: C has a precision argument for format $x, ${language} does not.\n";
 166         next;
 167       } elsif (not exists($orig->{prec_idx}) and exists($new->{prec_idx})) {
 168         print "MISMATCH ${key}: $language has a precision argument for format $x, C does not.\n";
 169         next;
 170       } elsif ($orig->{prec_idx} != $new->{prec_idx}) {
 171         print "MISMATCH ${key}: C and $language disagree on precision argument for format $x.\n";
 172         next;
 173       }
 174     }
 175   }
 176 }
 177
 178 sub read_language ($) {
 179   my $fname = shift;
 180   my $fh = new FileHandle($fname, "r");
 181   return undef unless defined $fh;
 182   my $res = {};
 183   while (defined($_ = $fh->getline)) {
 184     chomp;
 185     if (my ($key, $val) = /^"(\w+)" "(.+)";$/) {
 186       $val =~ s/\\(.)/$escapes{$1}/eg;
 187       $res->{$key} = $val;
 188     } else {
 189       print "Unrecognized line in $fname: $_\n";
 190     }
 191   }
 192   return $res;
 193 }
 194
 195 $lang{C} = read_language("strings.db");
 196
 197 foreach my $language (@ARGV) {
 198   next if exists $lang{$language};
 199   $lang{$language} = read_language("${language}/strings.db")
 200     or die "Unable to read $language: $!";
 201   foreach my $key (keys %{$lang{$language}}) {
 202     if (not $lang{C}->{$key}) {
 203       print "Extra entry in ${language}: $key\n";
 204       next;
 205     }
 206     compare_formats($language, $key, $lang{C}->{$key}, $lang{$language}->{$key});
 207   }
 208 }