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-F]+)\tU\+([0-9A-F]+)\t/) {
  $T{ hex $1 } = hex $2;
} elsif (/^#\?o ([A-Za-z0-9-]+)="([^"]+)"/) {
  my $n = $1; $n =~ tr/-/_/; $option{$n} = $2;
}
}

require 'internal.pl';
$option{offset} ||= &internal::cp_start (%option) || $internal::cp_start{ $option{charset_name} || $option{table_name} };

my (@T, @U);
$option{_start} = $option{charset_chars} == 94 ? 0x21 : 0x20;
@U = sort { $a->[0] <=> $b->[0] }
     map { 
       [ ($option{charset_dimension} > 1 ?
          (int ($_ / 0x100) - $option{_start}) * $option{charset_chars} : 0)
         + (($_ % 0x100) - $option{_start}) + $option{offset},
         $T{ $_ } ]
     } keys %T;

my $tbl = '';
my $pack = '';
for (@U) {
  for ($_->[0], $_->[1]) {
    $_ = chr $_; $_ = $_ eq "\\" ? "\\\\" : $_ eq q(') ? q(\') : $_;
    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;
use vars qw/%L2U %U2L \$VERSION/;
\$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.


#

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

print $tbl,"\nEND\n";

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