Table/tool/tbl2pm.pl

#!/usr/bin/perl
use strict;
use 5.7.3;

=head1 NAME

tbl2pm --- Perl module generator from (completed) PETBL
table file

=head1 DESCRIPTION

This script generates dumped perl module file of convertion
table used with Encode::Table module.

=head1 USAGE

 $ ./tbl2pm.pl table.tbl > table.pm

=cut

require Encode;
my %T;
my %option;
while (<>) {
if (/^((?:0x|[0-9A-Za-z]+[+-])[0-9A-F]+)\tU\+([0-9A-F]+)\t/) {
  $T{ $1 } = hex $2;
} elsif (/^#\?o ([A-Za-z0-9-]+)="((?:[^"\\]|\\.)+)"/) {
  my ($n,$v) = ($1,$2); $n =~ tr/-/_/; $v =~ s/\\(.)/$1/g; $option{$n} = $v;
}
}

require 'internal.pl';
$option{offset} ||= &internal::cp_start (%option) || $internal::cp_start{ $option{charset_name} || $option{table_name} };
if ($option{map_internal}) {
  eval qq{\$option{map_internal} = sub { $option{map_internal} }} or die $@;
} else {
  $option{map_internal} = sub {
    my $c = shift;  $c =~ s/0x//;  $c = hex $c;
    ($option{charset_dimension} > 1 ?
        (int ($c / 0x100) - $option{_start}) * $option{charset_chars} : 0)
      + (($c % 0x100) - $option{_start}) + $option{offset};
  };
}

my (@T, @U);
$option{_start} = $option{charset_chars} == 94 ? 0x21 : 0x20;
@U = sort { $a->[0] <=> $b->[0] }
     map { [ &{$option{map_internal}} ($_), $T{ $_ } ] } keys %T;

my $tbl = '';
my $pack = '';
for (@U) {
  for ($_->[0], $_->[1]) {
    $_ = chr $_;
    Encode::_utf8_off ($_);
    $tbl .= $_;
    $pack .= 'a' . length ($_);
  }
}

print <<EOH;
## This file is auto-generated (at @{[ sprintf '%04d-%02d-%02dT%02d:%02d:%02dZ', (gmtime)[5]+1900, (gmtime)[4]+1, (gmtime)[3,2,1,0] ]}).
## Do not edit by hand!

=head1 NAME

Encode::Table::$option{table_name} --- Convertion tables
used with Encode::Table, C<$option{table_name}_to_ucs>
and C<ucs_to_$option{table_name}>

=head1 TABLES

=over 4

=item $option{table_name}_to_ucs

Convertion table of $option{table_name} -> ucs

=item ucs_to_$option{table_name}

Convertion table of ucs -> $option{table_name}

=back

=head1 SEE ALSO

Encode::Table

=head1 LICENSE

See source table of this module.  (It may be named as
C<$option{table_name}.tbr>.)

=cut

package Encode::Table::$option{table_name};
use strict;
our \$VERSION = q(@{[sprintf '%04d.%02d%02d', (gmtime)[5]+1900, (gmtime)[4]+1, (gmtime)[3]]});

## These tables are embeded in binary, so that your editor
## might break the data or might hang up.


#

our %L2U = map {Encode::_utf8_on (\$_) if length \$_ > 1; \$_} unpack
(q{$pack}, <<'END');
EOH

print $tbl,"\nEND\n";

print <<EOH;
our %U2L = reverse %L2U;
sub import {
  \$Encode::Table::TABLE{$option{table_name}_to_ucs} = \\%L2U;
  \$Encode::Table::TABLE{ucs_to_$option{table_name}} = \\%U2L;
}
1;
### $option{table_name}.pm ends here
EOH


=head1 SEE ALSO

Encode::Table, internal.pl

=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/12/12 07:45:17 $
### tbl2pm.pl ends here
1	wakaba	1.1	#!/usr/bin/perl
2			use strict;
3			use 5.7.3;
4
5	wakaba	1.2	=head1 NAME
6
7			tbl2pm --- Perl module generator from (completed) PETBL
8			table file
9
10			=head1 DESCRIPTION
11
12			This script generates dumped perl module file of convertion
13			table used with Encode::Table module.
14
15			=head1 USAGE
16
17			$ ./tbl2pm.pl table.tbl > table.pm
18
19			=cut
20
21	wakaba	1.1	require Encode;
22			my %T;
23			my %option;
24			while (<>) {
25	wakaba	1.6	if (/^((?:0x\|[0-9A-Za-z]+[+-])[0-9A-F]+)\tU\+([0-9A-F]+)\t/) {
26			$T{ $1 } = hex $2;
27			} elsif (/^#\?o ([A-Za-z0-9-]+)="((?:[^"\\]\|\\.)+)"/) {
28			my ($n,$v) = ($1,$2); $n =~ tr/-/_/; $v =~ s/\\(.)/$1/g; $option{$n} = $v;
29	wakaba	1.1	}
30			}
31
32			require 'internal.pl';
33			$option{offset} \|\|= &internal::cp_start (%option) \|\| $internal::cp_start{ $option{charset_name} \|\| $option{table_name} };
34	wakaba	1.6	if ($option{map_internal}) {
35			eval qq{\$option{map_internal} = sub { $option{map_internal} }} or die $@;
36			} else {
37			$option{map_internal} = sub {
38			my $c = shift; $c =~ s/0x//; $c = hex $c;
39			($option{charset_dimension} > 1 ?
40			(int ($c / 0x100) - $option{_start}) * $option{charset_chars} : 0)
41			+ (($c % 0x100) - $option{_start}) + $option{offset};
42			};
43			}
44	wakaba	1.1
45			my (@T, @U);
46			$option{_start} = $option{charset_chars} == 94 ? 0x21 : 0x20;
47			@U = sort { $a->[0] <=> $b->[0] }
48	wakaba	1.6	map { [ &{$option{map_internal}} ($_), $T{ $_ } ] } keys %T;
49	wakaba	1.1
50			my $tbl = '';
51			my $pack = '';
52			for (@U) {
53			for ($_->[0], $_->[1]) {
54	wakaba	1.4	$_ = chr $_;
55	wakaba	1.1	Encode::_utf8_off ($_);
56			$tbl .= $_;
57			$pack .= 'a' . length ($_);
58			}
59			}
60
61			print <<EOH;
62			## This file is auto-generated (at @{[ sprintf '%04d-%02d-%02dT%02d:%02d:%02dZ', (gmtime)[5]+1900, (gmtime)[4]+1, (gmtime)[3,2,1,0] ]}).
63			## Do not edit by hand!
64
65			=head1 NAME
66
67			Encode::Table::$option{table_name} --- Convertion tables
68			used with Encode::Table, C<$option{table_name}_to_ucs>
69			and C<ucs_to_$option{table_name}>
70
71			=head1 TABLES
72
73			=over 4
74
75			=item $option{table_name}_to_ucs
76
77			Convertion table of $option{table_name} -> ucs
78
79			=item ucs_to_$option{table_name}
80
81			Convertion table of ucs -> $option{table_name}
82
83			=back
84
85			=head1 SEE ALSO
86
87			Encode::Table
88
89			=head1 LICENSE
90
91			See source table of this module. (It may be named as
92			C<$option{table_name}.tbr>.)
93
94			=cut
95
96			package Encode::Table::$option{table_name};
97			use strict;
98	wakaba	1.5	our \$VERSION = q(@{[sprintf '%04d.%02d%02d', (gmtime)[5]+1900, (gmtime)[4]+1, (gmtime)[3]]});
99	wakaba	1.1
100			## These tables are embeded in binary, so that your editor
101			## might break the data or might hang up.
102
103
104
105
106
107
108
109
110
111			#
112
113	wakaba	1.5	our %L2U = map {Encode::_utf8_on (\$_) if length \$_ > 1; \$_} unpack
114	wakaba	1.2	(q{$pack}, <<'END');
115	wakaba	1.1	EOH
116
117			print $tbl,"\nEND\n";
118
119			print <<EOH;
120	wakaba	1.5	our %U2L = reverse %L2U;
121	wakaba	1.1	sub import {
122	wakaba	1.2	\$Encode::Table::TABLE{$option{table_name}_to_ucs} = \\%L2U;
123			\$Encode::Table::TABLE{ucs_to_$option{table_name}} = \\%U2L;
124	wakaba	1.1	}
125			1;
126	wakaba	1.2	### $option{table_name}.pm ends here
127	wakaba	1.1	EOH
128
129	wakaba	1.2
130			=head1 SEE ALSO
131
132			Encode::Table, internal.pl
133
134			=head1 AUTHOR
135
136			Nanashi-san
137
138			=head1 LICENSE
139
140			Copyright 2002 AUTHOR
141
142			This library is free software; you can redistribute it
143			and/or modify it under the same terms as Perl itself.
144
145			AUTHOR does NOT claim any right to the data generated by
146			this script. License of generated data fully depends
147			author of source data.
148
149			=cut
150
151	wakaba	1.6	1; ## $Date: 2002/12/12 07:45:17 $
152	wakaba	1.1	### tbl2pm.pl ends here