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 ($) {
  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>' :
  '';
}
}

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, $_ unless $o->{_imported_file};
    } 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} } } ($o, \%opt) if ref $CMD{ $opt{cmd} };
    } elsif (/^##/) {   ## Comment
      push @r, $_;
    } elsif (/^#;/) {   ## Comment
    } elsif (/^#/) {    ## Comment or unsupported function
      push @r, $_;
    } 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 ($opt0, $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})) : '';
    $opt->{except} .= $opt0->{except} if $opt0->{except};
    array_to_table (\@tbl, {offset => hex $opt->{offset},
      fallback => $opt->{fallback}, mode => $m,
      except => $opt->{except}, right => $opt->{right},
      _imported_file => 1});
  } 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/13 08:34:56 $
### tbr2tbl.pl ends here
1	wakaba	1.1	#!/usr/bin/perl
2			use strict;
3
4	wakaba	1.2	=head1 NAME
5
6			tbr2tbl --- PETBL/1.0 source(s) to completed table converter
7
8			=cut
9	wakaba	1.1
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	wakaba	1.5	my $U = shift;
95			if ($U =~ /[^0-9]/) {
96			$U =~ s/^[Uu]\+\|^0[Xx]//;
97			$U = hex $U;
98			}
99	wakaba	1.1	## TODO: be more strict!
100	wakaba	1.5	$U < 0x0020 ? '<control>' :
101			$U < 0x007F ? $name{$U} :
102			$U < 0x00A0 ? '<control>' :
103			$name{$U} ? $name{$U} :
104			$U < 0x00A0 ? '<control>' :
105			$U < 0x3400 ? '' :
106			$U < 0xA000 ? '<cjk>' :
107			$U < 0xE000 ? '<hangul>' :
108			$U < 0xF900 ? '<private>' :
109	wakaba	1.1	'';
110			}
111			}
112
113			sub array_to_table (@%) {
114			my ($source, $o) = @_;
115			my @r; $o->{mode}->{DEFAULT} = 1;
116			my $mode = 'DEFAULT';
117			for (@$source) {
118			if (/^#\?if-mode ([A-Za-z0-9-]+)/) {
119			$mode = $1;
120			} elsif (/^#\?end-if-mode/) {
121			$mode = 'DEFAULT';
122			} elsif ($o->{mode}->{$mode}) { ## mode is enabled
123
124			if (/^#\?o/) { ## table option
125	wakaba	1.6	push @r, $_ unless $o->{_imported_file};
126	wakaba	1.1	} elsif (s/^#\?([A-Za-z0-9-]+)//) {
127			my %opt = (cmd => $1);
128			s{ ([A-Za-z0-9-]+)=(?:"((?:[^"\\]\|\\.)*)"\|([A-Za-z0-9-]+))
129			\| ([A-Za-z0-9-]+)}{
130			my ($N, $V, $v, $n) = ($1, $2, $3, $4);
131			$V =~ s/\\(.)/$1/g;
132			$opt{ $N \|\| $n } = $n ? 1 : ($V \|\| $v);
133			}gex;
134	wakaba	1.6	push @r, &{ $CMD{ $opt{cmd} } } ($o, \%opt) if ref $CMD{ $opt{cmd} };
135	wakaba	1.1	} elsif (/^##/) { ## Comment
136			push @r, $_;
137	wakaba	1.3	} elsif (/^#;/) { ## Comment
138	wakaba	1.1	} elsif (/^#/) { ## Comment or unsupported function
139	wakaba	1.3	push @r, $_;
140	wakaba	1.5	} elsif (/^0x($o->{except} [0-9A-Fa-f]+)(?:\t([^\t])(?:\t([^\t])(?:\t(.*))?)?)?/x) {
141	wakaba	1.1	my ($u, $l, $f, $m) = (hex $1, $2, $3, $4);
142			$f = $o->{fallback} if $o->{fallback};
143			my $offset = $o->{offset};
144			$offset += $u + $offset > 0xFF ? 0x8080 : 0x80 if $o->{right};
145			$m =~ s/^#\s*//;
146			push @r, sprintf qq{0x%02X\t%s\t%s\t# %s},
147			$u+$offset, $l, $f, $m \|\| charname ($l);
148			} elsif (/^$/) {
149			} else {
150	wakaba	1.3	#push @r, $_;
151	wakaba	1.1	}
152
153			} # / mode is enabled
154			}
155			@r;
156			}
157
158			$CMD{import} = sub {
159	wakaba	1.6	my ($opt0, $opt) = @_;
160	wakaba	1.1	if ($opt->{src}) {
161			## BUG: resolve of relative path
162			open TBL, $opt->{src} or die "$0: $opt->{src}: Imported table not found";
163			my @tbl = <TBL>; close TBL; map {s/[\x0D\x0A]+$//} @tbl;
164			my $m = {}; for (split /,/, $opt->{mode}) { $m->{$_} = 1 }
165			shift (@tbl) if $tbl[0] =~ m!^#\?PETBL/1.0 SOURCE!;
166	wakaba	1.3	$opt->{except} = $opt->{except} ? qq((?!(?i)$opt->{except})) : '';
167	wakaba	1.7	$opt->{except} .= $opt0->{except} if $opt0->{except};
168	wakaba	1.1	array_to_table (\@tbl, {offset => hex $opt->{offset},
169			fallback => $opt->{fallback}, mode => $m,
170	wakaba	1.6	except => $opt->{except}, right => $opt->{right},
171			_imported_file => 1});
172	wakaba	1.1	} elsif ($opt->{'std-cl'}) { @{ $C{tbl_std_cl} };
173			} elsif ($opt->{'std-cr'}) { @{ $C{tbl_std_cr} };
174			} elsif ($opt->{'std-0x20'} \|\| $opt->{'std-sp'}) { $C{tbl_std_20};
175			} elsif ($opt->{'std-0x7F'} \|\| $opt->{'std-del'}) { $C{tbl_std_7f};
176			} elsif ($opt->{'std-0xA0'}) { $C{tbl_std_a0};
177			} elsif ($opt->{'std-0xFF'}) { $C{tbl_std_ff};
178			}
179			};
180
181			my @src;
182			while (<>) {
183			s/[\x0D\x0A]+$//;
184			push @src, $_;
185			}
186			shift (@src) if $src[0] =~ m!^#\?PETBL/1.0 SOURCE!;
187			@src = sort {
188			$a =~ /^#/ ? 0 :
189			$b =~ /^#/ ? 0 : $a cmp $b
190			} array_to_table (\@src);
191
192			binmode STDOUT;
193			print "#?PETBL/1.0\n";
194			print join ("\n", @src)."\n";
195	wakaba	1.2
196
197			=head1 AUTHOR
198
199			Nanashi-san
200
201			=head1 LICENSE
202
203			Copyright 2002 AUTHOR
204
205			This library is free software; you can redistribute it
206			and/or modify it under the same terms as Perl itself.
207
208			AUTHOR does NOT claim any right to the data generated by
209			this script. License of generated data fully depends
210			author of source data.
211
212			=cut
213
214	wakaba	1.7	1; ## $Date: 2002/10/13 08:34:56 $
215	wakaba	1.2	### tbr2tbl.pl ends here