pintos-os.org Git - pspp/blob - src/data/sys-file-encoding.pl

   1 #! /usr/bin/perl
   2 #    Copyright (C) 2020  Free Software Foundation
   3
   4 #    This program is free software: you can redistribute it and/or modify
   5 #    it under the terms of the GNU General Public License as published by
   6 #    the Free Software Foundation, either version 3 of the License, or
   7 #    (at your option) any later version.
   8
   9 #    This program is distributed in the hope that it will be useful,
  10 #    but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 #    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 #    GNU General Public License for more details.
  13
  14 #    You should have received a copy of the GNU General Public License
  15 #    along with this program.  If not, see <http://www.gnu.org/licenses/>.
  16
  17
  18 use strict;
  19 use warnings;
  20
  21 if (-t 0 || @ARGV) {
  22     print <<EOF;
  23 $0: generate code page tables from ICU encoding list
  24 usage: $0 < convrtrs.txt > sys-file-encoding.c
  25
  26 To regenerate the encoding data, get the latest ICU encoding data from:
  27 http://source.icu-project.org/repos/icu/icu/trunk/source/data/mappings/convrtrs.txt
  28 then convert it with this script using the command above.
  29 EOF
  30     exit (@ARGV && $ARGV[0] eq '--help' ? 0 : 1);
  31 }
  32
  33 open (CONVERTERS, '<', 'convrtrs.txt')
  34   or die "convrtrs.txt: open failed ($!)\n";
  35
  36 our $WINDOWS = 3;               # Windows code pages.
  37 our $IBM = 2;                   # IBM code pages.
  38 our $CP = 1;                    # Java (?) code pages.
  39 our %sources = ($WINDOWS => "windows", $IBM => "ibm", $CP => "cp");
  40
  41 my $converter = "";
  42 while (<CONVERTERS>) {
  43     chomp;
  44     s/#.*//;
  45     if (s/^\s+//) {
  46         $converter .= " $_";
  47     } else {
  48         process_converter ($converter);
  49         $converter = $_;
  50     }
  51 }
  52 process_converter ($converter);
  53 close (CONVERTERS);
  54
  55 our %codepages;
  56
  57 print <<'EOF';
  58 /* -*- mode: c; buffer-read-only: t -*-
  59
  60    Generated by sys-file-encoding.pl.  Do not modify!
  61 */
  62
  63 #include <config.h>
  64
  65 #include "data/sys-file-private.h"
  66
  67 struct sys_encoding sys_codepage_number_to_name[] = {
  68 EOF
  69 for my $cpnumber (sort { $a <=> $b } (keys (%codepages))) {
  70     my $source = max (keys (%{$codepages{$cpnumber}}));
  71     my $name = ${$codepages{$cpnumber}{$source}}[0];
  72     print "  { $cpnumber, \"$name\" },\n";
  73 }
  74 print "  { 0, NULL }\n";
  75 print "};\n\n";
  76
  77 my %names;
  78 for my $cpnumber (sort { $a <=> $b } (keys (%codepages))) {
  79     for my $source (keys (%{$codepages{$cpnumber}})) {
  80         for my $name (@{$codepages{$cpnumber}{$source}}) {
  81             push(@{$names{$name}{$source}}, $cpnumber);
  82         }
  83     }
  84 }
  85 print "struct sys_encoding sys_codepage_name_to_number[] = {\n";
  86 for my $name (sort (keys (%names))) {
  87     for my $source (reverse (sort (keys (%sources)))) {
  88         next if !exists ($names{$name}{$source});
  89         my (@numbers) = @{$names{$name}{$source}};
  90
  91         # The only two encodings that currently print this are KSC_5601
  92         # and KS_C_5601-1987, for code pages 949 and 51949.  It looks to
  93         # me like the correct code page number is 949, which is the one
  94         # chosen (because the numbers are in sorted order).
  95         print "  /* $name has multiple numbers for $sources{$source}: @numbers */\n"
  96           if @numbers > 1;
  97
  98         print "  { $numbers[0], \"$name\" },\n";
  99         last;
 100     }
 101 }
 102 print "  { 0, NULL }\n";
 103 print "};\n";
 104
 105 sub process_converter {
 106     my ($converter) = @_;
 107     return if $converter =~ /^\s*$/;
 108     return if $converter =~ /^\s*\{/;
 109
 110     my %cps;
 111     my @iana;
 112     my @other;
 113
 114     my @fields = split (' ', $converter);
 115     while (@fields) {
 116         my $name = shift (@fields);
 117         if (@fields && $fields[0] eq '{') {
 118             shift (@fields);
 119
 120             my (%standards);
 121             for (;;) {
 122                 my $standard = shift (@fields);
 123                 last if $standard eq '}';
 124                 $standards{$standard} = 1;
 125             }
 126             if (exists $standards{'IANA*'}) {
 127                 unshift (@iana, $name);
 128             } elsif (exists $standards{'IANA'}) {
 129                 push (@iana, $name);
 130             } elsif (grep (/\*$/, keys %standards)) {
 131                 unshift (@other, $name);
 132             } else {
 133                 push (@other, $name);
 134             }
 135         } else {
 136             # Untagged names are completely nonstandard.
 137             next;
 138         }
 139
 140         my $number;
 141         if (($number) = $name =~ /^cp([0-9]+)$/) {
 142             $cps{$CP} = int ($number);
 143         } elsif (($number) = $name =~ /^windows-([0-9]+)$/) {
 144             $cps{$WINDOWS} = int ($number);
 145         } elsif (($number) = $name =~ /^ibm-([0-9]+)$/) {
 146             $cps{$IBM} = int ($number);
 147         } else {
 148             next;
 149         }
 150     }
 151
 152     # If there are no tagged names then this is completely nonstandard.
 153     return if !@iana && !@other;
 154
 155     $codepages{$cps{$_}}{$_} = [@iana, @other] for keys (%cps);
 156 }
 157
 158 sub max {
 159     my ($best);
 160     for my $x (@_) {
 161         $best = $x if !defined ($best) || $x > $best;
 162     }
 163     return $best;
 164 }