Commit | Line | Data |
51ef4e11 |
1 | package Encode::Tcl; |
2 | use strict; |
3 | use Encode qw(find_encoding); |
4 | use base 'Encode::Encoding'; |
5 | use Carp; |
6 | |
fc6a272d |
7 | =head1 NAME |
8 | |
9 | Encode::Tcl - Tcl encodings |
10 | |
11 | =cut |
51ef4e11 |
12 | |
13 | sub INC_search |
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 encode |
44 | { |
45 | my $obj = shift; |
46 | my $new = $obj->loadEncoding; |
47 | return undef unless (defined $new); |
48 | return $new->encode(@_); |
49 | } |
50 | |
51 | sub new_sequence |
52 | { |
53 | my $obj = shift; |
54 | my $new = $obj->loadEncoding; |
55 | return undef unless (defined $new); |
56 | return $new->new_sequence(@_); |
57 | } |
58 | |
59 | sub decode |
60 | { |
61 | my $obj = shift; |
62 | my $new = $obj->loadEncoding; |
63 | return undef unless (defined $new); |
64 | return $new->decode(@_); |
65 | } |
66 | |
67 | sub loadEncoding |
68 | { |
69 | my $obj = shift; |
70 | my $file = $obj->{'File'}; |
71 | my $name = $obj->name; |
72 | if (open(my $fh,$file)) |
73 | { |
74 | my $type; |
75 | while (1) |
76 | { |
77 | my $line = <$fh>; |
78 | $type = substr($line,0,1); |
79 | last unless $type eq '#'; |
80 | } |
81 | my $class = ref($obj).('::'.(($type eq 'E') ? 'Escape' : 'Table')); |
82 | carp "Loading $file"; |
83 | bless $obj,$class; |
84 | return $obj if $obj->read($fh,$obj->name,$type); |
85 | } |
86 | else |
87 | { |
88 | croak("Cannot open $file for ".$obj->name); |
89 | } |
90 | $obj->Undefine($name); |
91 | return undef; |
92 | } |
93 | |
94 | sub INC_find |
95 | { |
96 | my ($class,$name) = @_; |
97 | my $enc; |
98 | foreach my $dir (@INC) |
99 | { |
100 | last if ($enc = $class->loadEncoding($name,"$dir/Encode/$name.enc")); |
101 | } |
102 | return $enc; |
103 | } |
104 | |
105 | package Encode::Tcl::Table; |
106 | use base 'Encode::Encoding'; |
107 | |
108 | use Data::Dumper; |
109 | |
110 | sub read |
111 | { |
112 | my ($obj,$fh,$name,$type) = @_; |
113 | my $rep = $obj->can("rep_$type"); |
114 | my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>)); |
115 | my @touni; |
116 | my %fmuni; |
117 | my $count = 0; |
118 | $def = hex($def); |
119 | while ($pages--) |
120 | { |
121 | my $line = <$fh>; |
122 | chomp($line); |
123 | my $page = hex($line); |
124 | my @page; |
125 | my $ch = $page * 256; |
126 | for (my $i = 0; $i < 16; $i++) |
127 | { |
128 | my $line = <$fh>; |
129 | for (my $j = 0; $j < 16; $j++) |
130 | { |
131 | my $val = hex(substr($line,0,4,'')); |
132 | if ($val || !$ch) |
133 | { |
134 | my $uch = chr($val); |
135 | push(@page,$uch); |
136 | $fmuni{$uch} = $ch; |
137 | $count++; |
138 | } |
139 | else |
140 | { |
141 | push(@page,undef); |
142 | } |
143 | $ch++; |
144 | } |
145 | } |
146 | $touni[$page] = \@page; |
147 | } |
148 | $obj->{'Rep'} = $rep; |
149 | $obj->{'ToUni'} = \@touni; |
150 | $obj->{'FmUni'} = \%fmuni; |
151 | $obj->{'Def'} = $def; |
152 | $obj->{'Num'} = $count; |
153 | return $obj; |
154 | } |
155 | |
156 | sub rep_S { 'C' } |
157 | |
158 | sub rep_D { 'n' } |
159 | |
160 | sub rep_M { ($_[0] > 255) ? 'n' : 'C' } |
161 | |
162 | sub representation |
163 | { |
164 | my ($obj,$ch) = @_; |
165 | $ch = 0 unless @_ > 1; |
166 | $obj-{'Rep'}->($ch); |
167 | } |
168 | |
169 | sub decode |
170 | { |
171 | my ($obj,$str,$chk) = @_; |
172 | my $rep = $obj->{'Rep'}; |
173 | my $touni = $obj->{'ToUni'}; |
174 | my $uni = ''; |
175 | while (length($str)) |
176 | { |
177 | my $ch = ord(substr($str,0,1,'')); |
178 | my $x; |
179 | if (&$rep($ch) eq 'C') |
180 | { |
181 | $x = $touni->[0][$ch]; |
182 | } |
183 | else |
184 | { |
185 | $x = $touni->[$ch][ord(substr($str,0,1,''))]; |
186 | } |
187 | unless (defined $x) |
188 | { |
189 | last if $chk; |
190 | # What do we do here ? |
191 | $x = ''; |
192 | } |
193 | $uni .= $x; |
194 | } |
195 | $_[1] = $str if $chk; |
196 | return $uni; |
197 | } |
198 | |
199 | |
200 | sub encode |
201 | { |
202 | my ($obj,$uni,$chk) = @_; |
203 | my $fmuni = $obj->{'FmUni'}; |
204 | my $str = ''; |
205 | my $def = $obj->{'Def'}; |
206 | my $rep = $obj->{'Rep'}; |
207 | while (length($uni)) |
208 | { |
209 | my $ch = substr($uni,0,1,''); |
210 | my $x = $fmuni->{chr(ord($ch))}; |
211 | unless (defined $x) |
212 | { |
213 | last if ($chk); |
214 | $x = $def; |
215 | } |
216 | $str .= pack(&$rep($x),$x); |
217 | } |
218 | $_[1] = $uni if $chk; |
219 | return $str; |
220 | } |
221 | |
222 | package Encode::Tcl::Escape; |
223 | use base 'Encode::Encoding'; |
224 | |
225 | use Carp; |
226 | |
227 | sub read |
228 | { |
229 | my ($class,$fh,$name) = @_; |
230 | my %self = (Name => $name, Num => 0); |
231 | while (<$fh>) |
232 | { |
233 | my ($key,$val) = /^(\S+)\s+(.*)$/; |
234 | $val =~ s/^\{(.*?)\}/$1/g; |
235 | $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge; |
236 | $self{$key} = $val; |
237 | } |
238 | return bless \%self,$class; |
239 | } |
240 | |
241 | sub decode |
242 | { |
243 | croak("Not implemented yet"); |
244 | } |
245 | |
246 | sub encode |
247 | { |
248 | croak("Not implemented yet"); |
249 | } |
250 | |
251 | 1; |
252 | __END__ |