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