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, $_;
    } 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} [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/06 03:32:30 $
### 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			push @r, $_;
126			} 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			push @r, &{ $CMD{ $opt{cmd} } } (\%opt) if ref $CMD{ $opt{cmd} };
135			} 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			my ($opt) = @_;
160			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.1	array_to_table (\@tbl, {offset => hex $opt->{offset},
168			fallback => $opt->{fallback}, mode => $m,
169			except => $opt->{except}, right => $opt->{right}});
170			} elsif ($opt->{'std-cl'}) { @{ $C{tbl_std_cl} };
171			} elsif ($opt->{'std-cr'}) { @{ $C{tbl_std_cr} };
172			} elsif ($opt->{'std-0x20'} \|\| $opt->{'std-sp'}) { $C{tbl_std_20};
173			} elsif ($opt->{'std-0x7F'} \|\| $opt->{'std-del'}) { $C{tbl_std_7f};
174			} elsif ($opt->{'std-0xA0'}) { $C{tbl_std_a0};
175			} elsif ($opt->{'std-0xFF'}) { $C{tbl_std_ff};
176			}
177			};
178
179			my @src;
180			while (<>) {
181			s/[\x0D\x0A]+$//;
182			push @src, $_;
183			}
184			shift (@src) if $src[0] =~ m!^#\?PETBL/1.0 SOURCE!;
185			@src = sort {
186			$a =~ /^#/ ? 0 :
187			$b =~ /^#/ ? 0 : $a cmp $b
188			} array_to_table (\@src);
189
190			binmode STDOUT;
191			print "#?PETBL/1.0\n";
192			print join ("\n", @src)."\n";
193	wakaba	1.2
194
195			=head1 AUTHOR
196
197			Nanashi-san
198
199			=head1 LICENSE
200
201			Copyright 2002 AUTHOR
202
203			This library is free software; you can redistribute it
204			and/or modify it under the same terms as Perl itself.
205
206			AUTHOR does NOT claim any right to the data generated by
207			this script. License of generated data fully depends
208			author of source data.
209
210			=cut
211
212	wakaba	1.5	1; ## $Date: 2002/10/06 03:32:30 $
213	wakaba	1.2	### tbr2tbl.pl ends here