Table/tool/tbr2tbl.pl

#!/usr/bin/perl
use strict;

=head1 NAME

tbr2tbl --- PETBL/1.0 source(s) to completed table converter

=cut

my %CMD;
my %C;
$C{tbl_std_cl} = [split /\n/, <<EOH];
0x00    U+0000          # <control>
0x01    U+0001          # <control>
0x02    U+0002          # <control>
0x03    U+0003          # <control>
0x04    U+0004          # <control>
0x05    U+0005          # <control>
0x06    U+0006          # <control>
0x07    U+0007          # <control>
0x08    U+0008          # <control>
0x09    U+0009          # <control>
0x0A    U+000A          # <control>
0x0B    U+000B          # <control>
0x0C    U+000C          # <control>
0x0D    U+000D          # <control>
0x0E    U+000E          # <control>
0x0F    U+000F          # <control>
0x10    U+0010          # <control>
0x11    U+0011          # <control>
0x12    U+0012          # <control>
0x13    U+0013          # <control>
0x14    U+0014          # <control>
0x15    U+0015          # <control>
0x16    U+0016          # <control>
0x17    U+0017          # <control>
0x18    U+0018          # <control>
0x19    U+0019          # <control>
0x1A    U+001A          # <control>
0x1B    U+001B          # <control>
0x1C    U+001C          # <control>
0x1D    U+001D          # <control>
0x1E    U+001E          # <control>
0x1F    U+001F          # <control>
EOH
$C{tbl_std_20} = q(0x20 U+0020          # SPACE);
$C{tbl_std_7f} = q(0x7F U+007F          # DELETE);
$C{tbl_std_cr} = [split /\n/, <<EOH];
0x80    U+0080          # <control>
0x81    U+0081          # <control>
0x82    U+0082          # <control>
0x83    U+0083          # <control>
0x84    U+0084          # <control>
0x85    U+0085          # <control>
0x86    U+0086          # <control>
0x87    U+0087          # <control>
0x88    U+0088          # <control>
0x89    U+0089          # <control>
0x8A    U+008A          # <control>
0x8B    U+008B          # <control>
0x8C    U+008C          # <control>
0x8D    U+008D          # <control>
0x8E    U+008E          # <control>
0x8F    U+008F          # <control>
0x90    U+0090          # <control>
0x91    U+0091          # <control>
0x92    U+0092          # <control>
0x93    U+0093          # <control>
0x94    U+0094          # <control>
0x95    U+0095          # <control>
0x96    U+0096          # <control>
0x97    U+0097          # <control>
0x98    U+0098          # <control>
0x99    U+0099          # <control>
0x9A    U+009A          # <control>
0x9B    U+009B          # <control>
0x9C    U+009C          # <control>
0x9D    U+009D          # <control>
0x9E    U+009E          # <control>
0x9F    U+009F          # <control>
EOH
$C{tbl_std_a0} = q(0xA0                 # <reserved>);
$C{tbl_std_ff} = q(0xFF                 # <reserved>);

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

sub array_to_table (@%) {
  my ($source, $o) = @_;
  my @r;  $o->{mode}->{DEFAULT} = 1;
  my $mode = 'DEFAULT';
  for (@$source) {
    if (/^#\?if-mode ([A-Za-z0-9-]+)/) {
      $mode = $1;
    } elsif (/^#\?end-if-mode/) {
      $mode = 'DEFAULT';
    } elsif ($o->{mode}->{$mode}) {     ## mode is enabled
    
    if (/^#\?o/) {      ## table option
      push @r, $_;
    } elsif (s/^#\?([A-Za-z0-9-]+)//) {
      my %opt = (cmd => $1);
      s{ ([A-Za-z0-9-]+)=(?:"((?:[^"\\]|\\.)*)"|([A-Za-z0-9-]+)) 
       | ([A-Za-z0-9-]+)}{
        my ($N, $V, $v, $n) = ($1, $2, $3, $4);
        $V =~ s/\\(.)/$1/g;
        $opt{ $N || $n } = $n ? 1 : ($V || $v);
      }gex;
      push @r, &{ $CMD{ $opt{cmd} } } (\%opt) if ref $CMD{ $opt{cmd} };
    } elsif (/^##/) {   ## Comment
      push @r, $_;
    } elsif (/^#/) {    ## Comment or unsupported function
    } elsif (/^0x($o->{except} [0-9A-Fa-f]+)\t([^\t]*)\t([^\t]*)\t(.*)/x) {
      my ($u, $l, $f, $m) = (hex $1, $2, $3, $4);
      $f = $o->{fallback} if $o->{fallback};
      my $offset = $o->{offset};
      $offset += $u + $offset > 0xFF ? 0x8080 : 0x80 if $o->{right};
      $m =~ s/^#\s*//;
      push @r, sprintf qq{0x%02X\t%s\t%s\t# %s},
        $u+$offset, $l, $f, $m || charname ($l);
    } elsif (/^$/) {
    } else {
      push @r, $_;
    }
    
    }   # / mode is enabled
  }
  @r;
}

$CMD{import} = sub {
  my ($opt) = @_;
  if ($opt->{src}) {
    ## BUG: resolve of relative path
    open TBL, $opt->{src} or die "$0: $opt->{src}: Imported table not found";
    my @tbl = <TBL>;  close TBL;  map {s/[\x0D\x0A]+$//} @tbl;
    my $m = {}; for (split /,/, $opt->{mode}) { $m->{$_} = 1 }
    shift (@tbl) if $tbl[0] =~ m!^#\?PETBL/1.0 SOURCE!;
    array_to_table (\@tbl, {offset => hex $opt->{offset},
      fallback => $opt->{fallback}, mode => $m,
      except => $opt->{except}, right => $opt->{right}});
  } elsif ($opt->{'std-cl'}) { @{ $C{tbl_std_cl} };
  } elsif ($opt->{'std-cr'}) { @{ $C{tbl_std_cr} };
  } elsif ($opt->{'std-0x20'} || $opt->{'std-sp'}) { $C{tbl_std_20};
  } elsif ($opt->{'std-0x7F'} || $opt->{'std-del'}) { $C{tbl_std_7f};
  } elsif ($opt->{'std-0xA0'}) { $C{tbl_std_a0};
  } elsif ($opt->{'std-0xFF'}) { $C{tbl_std_ff};
  }
};

my @src;
while (<>) {
  s/[\x0D\x0A]+$//;
  push @src, $_;
}
shift (@src) if $src[0] =~ m!^#\?PETBL/1.0 SOURCE!;
@src = sort {
$a =~ /^#/ ? 0 :
$b =~ /^#/ ? 0 : $a cmp $b
} array_to_table (\@src);

binmode STDOUT;
print "#?PETBL/1.0\n";
print join ("\n", @src)."\n";


=head1 AUTHOR

Nanashi-san

=head1 LICENSE

Copyright 2002 AUTHOR

This library is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.

AUTHOR does NOT claim any right to the data generated by
this script.  License of generated data fully depends
author of source data.

=cut

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