Table/tool/ucm2tbl.pl

#!/usr/bin/perl

=head1 NAME

ucm2tbl --- Mapping table converter, ucm to PETBL/1.0 format

=head1 USAGE

 $ perl ucm2tbl.pl cp932.ucm > cp932.tbl

=cut

use strict;
{
my @name = split /\n/, require 'unicore/Name.pl';
my %name;
for (@name) {
if (/^(....)            ([^\t]+)/) {
  $name{hex $1} = $2;
}
}
sub charname ($) {
  my $U = shift;
  if ($U =~ /[^0-9]/) {
    $U =~ s/^[Uu]\+|^0[Xx]//;
    $U = hex $U;
  }
  ## TODO: be more strict!
  $U < 0x0020 ? '<control>' :
  $U < 0x007F ? $name{$U} :
  $U < 0x00A0 ? '<control>' :
  $name{$U} ? $name{$U} :
  $U < 0x00A0 ? '<control>' :
  $U < 0x3400 ? '' :
  $U < 0xA000 ? '<cjk>' :
  $U < 0xE000 ? '<hangul>' :
  $U < 0xF900 ? '<private>' :
  '';
}
}

print qq(#?PETBL/1.0\n);
my @char;
while (<>) {
  if (/^<U([0-9A-Fa-f]+)>\s+([0-9A-Fa-f\\Xx]+)\s+\|(\d)/) {
    my ($u, $c, $f) = (hex $1, $2, $3);
    $c =~ tr/\\Xx//d;  $c = hex $c;
    if ($c < 0x100) {
      push @char, sprintf q(0x%02X      U+%04X  %s      # %s%s), $c, $u, ['','<-','','->']->[$f], charname ($u), "\n";
    } else {
      push @char, sprintf q(0x%04X      U+%04X  %s      # %s%s), $c, $u, ['','<-','','->']->[$f], charname ($u), "\n";
    }
  } elsif (/^<code_set_name>\s+"([^"]+)"/) {
    print qq(#?o name="$1"\n);
  } elsif (/^<([^>]+)>\s+(.+)/) {
    my ($n,$v) = ($1,$2);  $v =~ s/([\\"])/\\$1/g;
    print qq(#?o ucm:$n="$v"\n);
  } elsif (s/^#\s?// && (tr/\x0A\x0D//d || 1)) {
    print qq(## $_\n);
  }
}
print sort @char;

=head1 AUTHOR

Nanashi-san (SuikaWiki:WindowsCodePage
<http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WindowsCodePage>)

=head1 LICENSE

Public Domain.

=cut

# $Date: 2002/11/02 12:10:45 $
1	wakaba	1.1	#!/usr/bin/perl
2
3			=head1 NAME
4
5			ucm2tbl --- Mapping table converter, ucm to PETBL/1.0 format
6
7			=head1 USAGE
8
9			$ perl ucm2tbl.pl cp932.ucm > cp932.tbl
10
11			=cut
12
13			use strict;
14			{
15			my @name = split /\n/, require 'unicore/Name.pl';
16			my %name;
17			for (@name) {
18			if (/^(....) ([^\t]+)/) {
19			$name{hex $1} = $2;
20			}
21			}
22			sub charname ($) {
23			my $U = shift;
24			if ($U =~ /[^0-9]/) {
25			$U =~ s/^[Uu]\+\|^0[Xx]//;
26			$U = hex $U;
27			}
28			## TODO: be more strict!
29			$U < 0x0020 ? '<control>' :
30			$U < 0x007F ? $name{$U} :
31			$U < 0x00A0 ? '<control>' :
32			$name{$U} ? $name{$U} :
33			$U < 0x00A0 ? '<control>' :
34			$U < 0x3400 ? '' :
35			$U < 0xA000 ? '<cjk>' :
36			$U < 0xE000 ? '<hangul>' :
37			$U < 0xF900 ? '<private>' :
38			'';
39			}
40			}
41
42			print qq(#?PETBL/1.0\n);
43			my @char;
44			while (<>) {
45			if (/^<U([0-9A-Fa-f]+)>\s+([0-9A-Fa-f\\Xx]+)\s+\\|(\d)/) {
46			my ($u, $c, $f) = (hex $1, $2, $3);
47			$c =~ tr/\\Xx//d; $c = hex $c;
48			if ($c < 0x100) {
49			push @char, sprintf q(0x%02X U+%04X %s # %s%s), $c, $u, ['','<-','','->']->[$f], charname ($u), "\n";
50			} else {
51			push @char, sprintf q(0x%04X U+%04X %s # %s%s), $c, $u, ['','<-','','->']->[$f], charname ($u), "\n";
52			}
53			} elsif (/^<code_set_name>\s+"([^"]+)"/) {
54			print qq(#?o name="$1"\n);
55			} elsif (/^<([^>]+)>\s+(.+)/) {
56			my ($n,$v) = ($1,$2); $v =~ s/([\\"])/\\$1/g;
57			print qq(#?o ucm:$n="$v"\n);
58			} elsif (s/^#\s?// && (tr/\x0A\x0D//d \|\| 1)) {
59			print qq(## $_\n);
60			}
61			}
62			print sort @char;
63
64			=head1 AUTHOR
65
66			Nanashi-san (SuikaWiki:WindowsCodePage
67			<http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WindowsCodePage>)
68
69			=head1 LICENSE
70
71			Public Domain.
72
73			=cut
74
75			# $Date: 2002/11/02 12:10:45 $