| 1 |
wakaba |
1.1 |
#!/usr/bin/perl
|
| 2 |
|
|
use strict;
|
| 3 |
|
|
|
| 4 |
|
|
|
| 5 |
|
|
my %CMD;
|
| 6 |
|
|
my %C;
|
| 7 |
|
|
$C{tbl_std_cl} = [split /\n/, <<EOH];
|
| 8 |
|
|
0x00 U+0000 # <control>
|
| 9 |
|
|
0x01 U+0001 # <control>
|
| 10 |
|
|
0x02 U+0002 # <control>
|
| 11 |
|
|
0x03 U+0003 # <control>
|
| 12 |
|
|
0x04 U+0004 # <control>
|
| 13 |
|
|
0x05 U+0005 # <control>
|
| 14 |
|
|
0x06 U+0006 # <control>
|
| 15 |
|
|
0x07 U+0007 # <control>
|
| 16 |
|
|
0x08 U+0008 # <control>
|
| 17 |
|
|
0x09 U+0009 # <control>
|
| 18 |
|
|
0x0A U+000A # <control>
|
| 19 |
|
|
0x0B U+000B # <control>
|
| 20 |
|
|
0x0C U+000C # <control>
|
| 21 |
|
|
0x0D U+000D # <control>
|
| 22 |
|
|
0x0E U+000E # <control>
|
| 23 |
|
|
0x0F U+000F # <control>
|
| 24 |
|
|
0x10 U+0010 # <control>
|
| 25 |
|
|
0x11 U+0011 # <control>
|
| 26 |
|
|
0x12 U+0012 # <control>
|
| 27 |
|
|
0x13 U+0013 # <control>
|
| 28 |
|
|
0x14 U+0014 # <control>
|
| 29 |
|
|
0x15 U+0015 # <control>
|
| 30 |
|
|
0x16 U+0016 # <control>
|
| 31 |
|
|
0x17 U+0017 # <control>
|
| 32 |
|
|
0x18 U+0018 # <control>
|
| 33 |
|
|
0x19 U+0019 # <control>
|
| 34 |
|
|
0x1A U+001A # <control>
|
| 35 |
|
|
0x1B U+001B # <control>
|
| 36 |
|
|
0x1C U+001C # <control>
|
| 37 |
|
|
0x1D U+001D # <control>
|
| 38 |
|
|
0x1E U+001E # <control>
|
| 39 |
|
|
0x1F U+001F # <control>
|
| 40 |
|
|
EOH
|
| 41 |
|
|
$C{tbl_std_20} = q(0x20 U+0020 # SPACE);
|
| 42 |
|
|
$C{tbl_std_7f} = q(0x7F U+007F # DELETE);
|
| 43 |
|
|
$C{tbl_std_cr} = [split /\n/, <<EOH];
|
| 44 |
|
|
0x80 U+0080 # <control>
|
| 45 |
|
|
0x81 U+0081 # <control>
|
| 46 |
|
|
0x82 U+0082 # <control>
|
| 47 |
|
|
0x83 U+0083 # <control>
|
| 48 |
|
|
0x84 U+0084 # <control>
|
| 49 |
|
|
0x85 U+0085 # <control>
|
| 50 |
|
|
0x86 U+0086 # <control>
|
| 51 |
|
|
0x87 U+0087 # <control>
|
| 52 |
|
|
0x88 U+0088 # <control>
|
| 53 |
|
|
0x89 U+0089 # <control>
|
| 54 |
|
|
0x8A U+008A # <control>
|
| 55 |
|
|
0x8B U+008B # <control>
|
| 56 |
|
|
0x8C U+008C # <control>
|
| 57 |
|
|
0x8D U+008D # <control>
|
| 58 |
|
|
0x8E U+008E # <control>
|
| 59 |
|
|
0x8F U+008F # <control>
|
| 60 |
|
|
0x90 U+0090 # <control>
|
| 61 |
|
|
0x91 U+0091 # <control>
|
| 62 |
|
|
0x92 U+0092 # <control>
|
| 63 |
|
|
0x93 U+0093 # <control>
|
| 64 |
|
|
0x94 U+0094 # <control>
|
| 65 |
|
|
0x95 U+0095 # <control>
|
| 66 |
|
|
0x96 U+0096 # <control>
|
| 67 |
|
|
0x97 U+0097 # <control>
|
| 68 |
|
|
0x98 U+0098 # <control>
|
| 69 |
|
|
0x99 U+0099 # <control>
|
| 70 |
|
|
0x9A U+009A # <control>
|
| 71 |
|
|
0x9B U+009B # <control>
|
| 72 |
|
|
0x9C U+009C # <control>
|
| 73 |
|
|
0x9D U+009D # <control>
|
| 74 |
|
|
0x9E U+009E # <control>
|
| 75 |
|
|
0x9F U+009F # <control>
|
| 76 |
|
|
EOH
|
| 77 |
|
|
$C{tbl_std_a0} = q(0xA0 # <reserved>);
|
| 78 |
|
|
$C{tbl_std_ff} = q(0xFF # <reserved>);
|
| 79 |
|
|
|
| 80 |
|
|
{
|
| 81 |
|
|
my @name = split /\n/, require 'unicore/Name.pl';
|
| 82 |
|
|
my %name;
|
| 83 |
|
|
for (@name) {
|
| 84 |
|
|
if (/^(....) ([^\t]+)/) {
|
| 85 |
|
|
$name{hex $1} = $2;
|
| 86 |
|
|
}
|
| 87 |
|
|
}
|
| 88 |
|
|
sub charname ($) {
|
| 89 |
|
|
## TODO: be more strict!
|
| 90 |
|
|
$_[0] < 0x0020 ? '<control>' :
|
| 91 |
|
|
$_[0] < 0x007F ? $name{$_[0]} :
|
| 92 |
|
|
$_[0] < 0x00A0 ? '<control>' :
|
| 93 |
|
|
$name{$_[0]} ? $name{$_[0]} :
|
| 94 |
|
|
$_[0] < 0x00A0 ? '<control>' :
|
| 95 |
|
|
$_[0] < 0x3400 ? '' :
|
| 96 |
|
|
$_[0] < 0xA000 ? '<cjk>' :
|
| 97 |
|
|
$_[0] < 0xE000 ? '<hangul>' :
|
| 98 |
|
|
$_[0] < 0xF900 ? '<private>' :
|
| 99 |
|
|
'';
|
| 100 |
|
|
}
|
| 101 |
|
|
}
|
| 102 |
|
|
|
| 103 |
|
|
sub array_to_table (@%) {
|
| 104 |
|
|
my ($source, $o) = @_;
|
| 105 |
|
|
my @r; $o->{mode}->{DEFAULT} = 1;
|
| 106 |
|
|
my $mode = 'DEFAULT';
|
| 107 |
|
|
for (@$source) {
|
| 108 |
|
|
if (/^#\?if-mode ([A-Za-z0-9-]+)/) {
|
| 109 |
|
|
$mode = $1;
|
| 110 |
|
|
} elsif (/^#\?end-if-mode/) {
|
| 111 |
|
|
$mode = 'DEFAULT';
|
| 112 |
|
|
} elsif ($o->{mode}->{$mode}) { ## mode is enabled
|
| 113 |
|
|
|
| 114 |
|
|
if (/^#\?o/) { ## table option
|
| 115 |
|
|
push @r, $_;
|
| 116 |
|
|
} elsif (s/^#\?([A-Za-z0-9-]+)//) {
|
| 117 |
|
|
my %opt = (cmd => $1);
|
| 118 |
|
|
s{ ([A-Za-z0-9-]+)=(?:"((?:[^"\\]|\\.)*)"|([A-Za-z0-9-]+))
|
| 119 |
|
|
| ([A-Za-z0-9-]+)}{
|
| 120 |
|
|
my ($N, $V, $v, $n) = ($1, $2, $3, $4);
|
| 121 |
|
|
$V =~ s/\\(.)/$1/g;
|
| 122 |
|
|
$opt{ $N || $n } = $n ? 1 : ($V || $v);
|
| 123 |
|
|
}gex;
|
| 124 |
|
|
push @r, &{ $CMD{ $opt{cmd} } } (\%opt) if ref $CMD{ $opt{cmd} };
|
| 125 |
|
|
} elsif (/^##/) { ## Comment
|
| 126 |
|
|
push @r, $_;
|
| 127 |
|
|
} elsif (/^#/) { ## Comment or unsupported function
|
| 128 |
|
|
} elsif (/^0x($o->{except} [0-9A-Fa-f]+)\t([^\t]*)\t([^\t]*)\t(.*)/x) {
|
| 129 |
|
|
my ($u, $l, $f, $m) = (hex $1, $2, $3, $4);
|
| 130 |
|
|
$f = $o->{fallback} if $o->{fallback};
|
| 131 |
|
|
my $offset = $o->{offset};
|
| 132 |
|
|
$offset += $u + $offset > 0xFF ? 0x8080 : 0x80 if $o->{right};
|
| 133 |
|
|
$m =~ s/^#\s*//;
|
| 134 |
|
|
push @r, sprintf qq{0x%02X\t%s\t%s\t# %s},
|
| 135 |
|
|
$u+$offset, $l, $f, $m || charname ($l);
|
| 136 |
|
|
} elsif (/^$/) {
|
| 137 |
|
|
} else {
|
| 138 |
|
|
push @r, $_;
|
| 139 |
|
|
}
|
| 140 |
|
|
|
| 141 |
|
|
} # / mode is enabled
|
| 142 |
|
|
}
|
| 143 |
|
|
@r;
|
| 144 |
|
|
}
|
| 145 |
|
|
|
| 146 |
|
|
$CMD{import} = sub {
|
| 147 |
|
|
my ($opt) = @_;
|
| 148 |
|
|
if ($opt->{src}) {
|
| 149 |
|
|
## BUG: resolve of relative path
|
| 150 |
|
|
open TBL, $opt->{src} or die "$0: $opt->{src}: Imported table not found";
|
| 151 |
|
|
my @tbl = <TBL>; close TBL; map {s/[\x0D\x0A]+$//} @tbl;
|
| 152 |
|
|
my $m = {}; for (split /,/, $opt->{mode}) { $m->{$_} = 1 }
|
| 153 |
|
|
shift (@tbl) if $tbl[0] =~ m!^#\?PETBL/1.0 SOURCE!;
|
| 154 |
|
|
array_to_table (\@tbl, {offset => hex $opt->{offset},
|
| 155 |
|
|
fallback => $opt->{fallback}, mode => $m,
|
| 156 |
|
|
except => $opt->{except}, right => $opt->{right}});
|
| 157 |
|
|
} elsif ($opt->{'std-cl'}) { @{ $C{tbl_std_cl} };
|
| 158 |
|
|
} elsif ($opt->{'std-cr'}) { @{ $C{tbl_std_cr} };
|
| 159 |
|
|
} elsif ($opt->{'std-0x20'} || $opt->{'std-sp'}) { $C{tbl_std_20};
|
| 160 |
|
|
} elsif ($opt->{'std-0x7F'} || $opt->{'std-del'}) { $C{tbl_std_7f};
|
| 161 |
|
|
} elsif ($opt->{'std-0xA0'}) { $C{tbl_std_a0};
|
| 162 |
|
|
} elsif ($opt->{'std-0xFF'}) { $C{tbl_std_ff};
|
| 163 |
|
|
}
|
| 164 |
|
|
};
|
| 165 |
|
|
|
| 166 |
|
|
my @src;
|
| 167 |
|
|
while (<>) {
|
| 168 |
|
|
s/[\x0D\x0A]+$//;
|
| 169 |
|
|
push @src, $_;
|
| 170 |
|
|
}
|
| 171 |
|
|
shift (@src) if $src[0] =~ m!^#\?PETBL/1.0 SOURCE!;
|
| 172 |
|
|
@src = sort {
|
| 173 |
|
|
$a =~ /^#/ ? 0 :
|
| 174 |
|
|
$b =~ /^#/ ? 0 : $a cmp $b
|
| 175 |
|
|
} array_to_table (\@src);
|
| 176 |
|
|
|
| 177 |
|
|
binmode STDOUT;
|
| 178 |
|
|
print "#?PETBL/1.0\n";
|
| 179 |
|
|
print join ("\n", @src)."\n";
|
Parent Directory
| 
Revision Log