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
    } elsif (/^#/) {    ## Comment or unsupported function
      push @r, $_;
    } elsif (/^0x($o->{except}  (?!3021)[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!;
    $opt->{except} = $opt->{except} ? qq((?!(?i)$opt->{except})) : '';
    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 01:34:55 $
### 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
133	} elsif (/^#/) { ## Comment or unsupported function
134	push @r, $_;
135	} elsif (/^0x($o->{except} (?!3021)[0-9A-Fa-f]+)\t([^\t])\t([^\t])\t(.*)/x) {
136	my ($u, $l, $f, $m) = (hex $1, $2, $3, $4);
137	$f = $o->{fallback} if $o->{fallback};
138	my $offset = $o->{offset};
139	$offset += $u + $offset > 0xFF ? 0x8080 : 0x80 if $o->{right};
140	$m =~ s/^#\s*//;
141	push @r, sprintf qq{0x%02X\t%s\t%s\t# %s},
142	$u+$offset, $l, $f, $m \|\| charname ($l);
143	} elsif (/^$/) {
144	} else {
145	#push @r, $_;
146	}
147
148	} # / mode is enabled
149	}
150	@r;
151	}
152
153	$CMD{import} = sub {
154	my ($opt) = @_;
155	if ($opt->{src}) {
156	## BUG: resolve of relative path
157	open TBL, $opt->{src} or die "$0: $opt->{src}: Imported table not found";
158	my @tbl = <TBL>; close TBL; map {s/[\x0D\x0A]+$//} @tbl;
159	my $m = {}; for (split /,/, $opt->{mode}) { $m->{$_} = 1 }
160	shift (@tbl) if $tbl[0] =~ m!^#\?PETBL/1.0 SOURCE!;
161	$opt->{except} = $opt->{except} ? qq((?!(?i)$opt->{except})) : '';
162	array_to_table (\@tbl, {offset => hex $opt->{offset},
163	fallback => $opt->{fallback}, mode => $m,
164	except => $opt->{except}, right => $opt->{right}});
165	} elsif ($opt->{'std-cl'}) { @{ $C{tbl_std_cl} };
166	} elsif ($opt->{'std-cr'}) { @{ $C{tbl_std_cr} };
167	} elsif ($opt->{'std-0x20'} \|\| $opt->{'std-sp'}) { $C{tbl_std_20};
168	} elsif ($opt->{'std-0x7F'} \|\| $opt->{'std-del'}) { $C{tbl_std_7f};
169	} elsif ($opt->{'std-0xA0'}) { $C{tbl_std_a0};
170	} elsif ($opt->{'std-0xFF'}) { $C{tbl_std_ff};
171	}
172	};
173
174	my @src;
175	while (<>) {
176	s/[\x0D\x0A]+$//;
177	push @src, $_;
178	}
179	shift (@src) if $src[0] =~ m!^#\?PETBL/1.0 SOURCE!;
180	@src = sort {
181	$a =~ /^#/ ? 0 :
182	$b =~ /^#/ ? 0 : $a cmp $b
183	} array_to_table (\@src);
184
185	binmode STDOUT;
186	print "#?PETBL/1.0\n";
187	print join ("\n", @src)."\n";
188
189
190	=head1 AUTHOR
191
192	Nanashi-san
193
194	=head1 LICENSE
195
196	Copyright 2002 AUTHOR
197
198	This library is free software; you can redistribute it
199	and/or modify it under the same terms as Perl itself.
200
201	AUTHOR does NOT claim any right to the data generated by
202	this script. License of generated data fully depends
203	author of source data.
204
205	=cut
206
207	1; ## $Date: 2002/10/05 01:34:55 $
208	### tbr2tbl.pl ends here