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