1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
package Encode::Tcl;
BEGIN {
if (ord("A") == 193) {
die "Encode::Tcl not supported on EBCDIC\n";
}
}
use strict;
our $VERSION = do {my @r=(q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r};
use Encode qw(find_encoding);
use base 'Encode::Encoding';
use Carp;
sub INC_search
{
foreach my $dir (@INC)
{
if (opendir(my $dh,"$dir/Encode"))
{
while (defined(my $name = readdir($dh)))
{
if ($name =~ /^(.*)\.enc$/)
{
my $canon = $1;
my $obj = find_encoding($canon, 1); # skip external tables
if (!defined($obj))
{
my $obj = bless { Name => $canon, File => "$dir/Encode/$name"},__PACKAGE__;
$obj->Define( $canon );
# warn "$canon => $obj\n";
}
}
}
closedir($dh);
}
}
}
sub import
{
INC_search();
}
sub no_map_in_encode ($$)
# codepoint, enc-name;
{
carp sprintf "\"\\N{U+%x}\" does not map to %s", @_;
# /* FIXME: Skip over the character, copy in replacement and continue
# * but that is messy so for now just fail.
# */
return;
}
sub no_map_in_decode ($$)
# enc-name, string beginning the malform char;
{
# /* UTF-8 is supposed to be "Universal" so should not happen */
croak sprintf "%s '%s' does not map to UTF-8", @_;
}
sub encode
{
my $obj = shift;
my $new = $obj->loadEncoding;
return undef unless (defined $new);
return $new->encode(@_);
}
sub new_sequence
{
my $obj = shift;
my $new = $obj->loadEncoding;
return undef unless (defined $new);
return $new->new_sequence(@_);
}
sub decode
{
my $obj = shift;
my $new = $obj->loadEncoding;
return undef unless (defined $new);
return $new->decode(@_);
}
sub loadEncoding
{
my $obj = shift;
my $file = $obj->{'File'};
my $name = $obj->name;
if (open(my $fh,$file))
{
my $type;
while (1)
{
my $line = <$fh>;
$type = substr($line,0,1);
last unless $type eq '#';
}
my $subclass =
($type eq 'X') ? 'Extended' :
($type eq 'E') ? 'Escape' : 'Table';
my $class = ref($obj) . '::' . $subclass;
# carp "Loading $file";
bless $obj,$class;
return $obj if $obj->read($fh,$obj->name,$type);
}
else
{
croak("Cannot open $file for ".$obj->name);
}
$obj->Undefine($name);
return undef;
}
sub INC_find
{
my ($class,$name) = @_;
my $enc;
foreach my $dir (@INC)
{
last if ($enc = $class->loadEncoding($name,"$dir/Encode/$name.enc"));
}
return $enc;
}
require Encode::Tcl::Table;
require Encode::Tcl::Escape;
require Encode::Tcl::Extended;
1;
__END__
=head1 NAME
Encode::Tcl - Tcl encodings
=head1 SYNOPSIS
use Encode;
use Encode::Tcl;
$unicode = decode('shiftjis', $shiftjis);
$shiftjis = encode('shiftjis', $unicode);
=head1 DESCRIPTION
This module provides the interface to encodings
defined by the format of encoding tables borrowed from Tcl
and not compiled in other Encode:: modules.
See also F<Encode/EncodeFormat.pod> and F<Encode/*.enc> files.
To find how to use this module in detail, see L<Encode>.
=head1 SEE ALSO
L<Encode>
L<Encode::Tcl::Table>
L<Encode::Tcl::Escape>
L<Encode::Tcl::Extended>
=cut
|
