Commit | Line | Data |
2c674647 |
1 | package Encode; |
2 | |
3 | $VERSION = 0.01; |
4 | |
5 | require DynaLoader; |
6 | require Exporter; |
7 | |
8 | @ISA = qw(Exporter DynaLoader); |
9 | |
10 | @EXPORT_OK = |
11 | qw( |
12 | bytes_to_utf8 |
13 | utf8_to_bytes |
14 | chars_to_utf8 |
15 | utf8_to_chars |
16 | utf8_to_chars_check |
17 | bytes_to_chars |
18 | chars_to_bytes |
19 | from_to |
20 | is_utf8 |
21 | on_utf8 |
22 | off_utf8 |
23 | utf_to_utf |
656753f8 |
24 | encodings |
2c674647 |
25 | ); |
26 | |
27 | bootstrap Encode (); |
28 | |
29 | =pod |
30 | |
31 | =head1 NAME |
32 | |
33 | Encode - character encodings |
34 | |
35 | =head2 TERMINOLOGY |
36 | |
37 | =over |
38 | |
39 | =item * |
40 | |
41 | I<char>: a character in the range 0..maxint (at least 2**32-1) |
42 | |
43 | =item * |
44 | |
45 | I<byte>: a character in the range 0..255 |
46 | |
47 | =back |
48 | |
49 | The marker [INTERNAL] marks Internal Implementation Details, in |
50 | general meant only for those who think they know what they are doing, |
51 | and such details may change in future releases. |
52 | |
53 | =head2 bytes |
54 | |
55 | =over 4 |
56 | |
57 | =item * |
58 | |
59 | bytes_to_utf8(STRING [, FROM]) |
60 | |
61 | The bytes in STRING are recoded in-place into UTF-8. If no FROM is |
62 | specified the bytes are expected to be encoded in US-ASCII or ISO |
63 | 8859-1 (Latin 1). Returns the new size of STRING, or C<undef> if |
64 | there's a failure. |
65 | |
656753f8 |
66 | [INTERNAL] Also the UTF-8 flag of STRING is turned on. |
2c674647 |
67 | |
68 | =item * |
69 | |
70 | utf8_to_bytes(STRING [, TO [, CHECK]]) |
71 | |
72 | The UTF-8 in STRING is decoded in-place into bytes. If no TO encoding |
73 | is specified the bytes are expected to be encoded in US-ASCII or ISO |
74 | 8859-1 (Latin 1). Returns the new size of STRING, or C<undef> if |
75 | there's a failure. |
76 | |
77 | What if there are characters > 255? What if the UTF-8 in STRING is |
78 | malformed? See L</"Handling Malformed Data">. |
79 | |
80 | [INTERNAL] The UTF-8 flag of STRING is not checked. |
81 | |
82 | =back |
83 | |
84 | =head2 chars |
85 | |
86 | =over 4 |
87 | |
88 | =item * |
89 | |
90 | chars_to_utf8(STRING) |
91 | |
92 | The chars in STRING are encoded in-place into UTF-8. Returns the new |
93 | size of STRING, or C<undef> if there's a failure. |
94 | |
95 | No assumptions are made on the encoding of the chars. If you want to |
96 | assume that the chars are Unicode and to trap illegal Unicode |
97 | characters, you must use C<from_to('Unicode', ...)>. |
98 | |
99 | [INTERNAL] Also the UTF-8 flag of STRING is turned on. |
100 | |
101 | =over 4 |
102 | |
103 | =item * |
104 | |
105 | utf8_to_chars(STRING) |
106 | |
107 | The UTF-8 in STRING is decoded in-place into chars. Returns the new |
656753f8 |
108 | size of STRING, or C<undef> if there's a failure. |
2c674647 |
109 | |
110 | If the UTF-8 in STRING is malformed C<undef> is returned, and also an |
111 | optional lexical warning (category utf8) is given. |
112 | |
113 | [INTERNAL] The UTF-8 flag of STRING is not checked. |
114 | |
115 | =item * |
116 | |
117 | utf8_to_chars_check(STRING [, CHECK]) |
118 | |
119 | (Note that special naming of this interface since a two-argument |
120 | utf8_to_chars() has different semantics.) |
121 | |
122 | The UTF-8 in STRING is decoded in-place into chars. Returns the new |
123 | size of STRING, or C<undef> if there is a failure. |
124 | |
125 | If the UTF-8 in STRING is malformed? See L</"Handling Malformed Data">. |
126 | |
127 | [INTERNAL] The UTF-8 flag of STRING is not checked. |
128 | |
129 | =back |
130 | |
131 | =head2 chars With Encoding |
132 | |
133 | =over 4 |
134 | |
135 | =item * |
136 | |
137 | chars_to_utf8(STRING, FROM [, CHECK]) |
138 | |
139 | The chars in STRING encoded in FROM are recoded in-place into UTF-8. |
140 | Returns the new size of STRING, or C<undef> if there's a failure. |
141 | |
142 | No assumptions are made on the encoding of the chars. If you want to |
143 | assume that the chars are Unicode and to trap illegal Unicode |
144 | characters, you must use C<from_to('Unicode', ...)>. |
145 | |
146 | [INTERNAL] Also the UTF-8 flag of STRING is turned on. |
147 | |
148 | =item * |
149 | |
150 | utf8_to_chars(STRING, TO [, CHECK]) |
151 | |
152 | The UTF-8 in STRING is decoded in-place into chars encoded in TO. |
153 | Returns the new size of STRING, or C<undef> if there's a failure. |
154 | |
155 | If the UTF-8 in STRING is malformed? See L</"Handling Malformed Data">. |
156 | |
157 | [INTERNAL] The UTF-8 flag of STRING is not checked. |
158 | |
159 | =item * |
160 | |
161 | bytes_to_chars(STRING, FROM [, CHECK]) |
162 | |
163 | The bytes in STRING encoded in FROM are recoded in-place into chars. |
164 | Returns the new size of STRING in bytes, or C<undef> if there's a |
165 | failure. |
166 | |
167 | If the mapping is impossible? See L</"Handling Malformed Data">. |
168 | |
169 | =item * |
170 | |
171 | chars_to_bytes(STRING, TO [, CHECK]) |
172 | |
173 | The chars in STRING are recoded in-place to bytes encoded in TO. |
174 | Returns the new size of STRING in bytes, or C<undef> if there's a |
175 | failure. |
176 | |
177 | If the mapping is impossible? See L</"Handling Malformed Data">. |
178 | |
179 | =item * |
180 | |
181 | from_to(STRING, FROM, TO [, CHECK]) |
182 | |
183 | The chars in STRING encoded in FROM are recoded in-place into TO. |
184 | Returns the new size of STRING, or C<undef> if there's a failure. |
185 | |
186 | If mapping between the encodings is impossible? |
187 | See L</"Handling Malformed Data">. |
188 | |
189 | [INTERNAL] If TO is UTF-8, also the UTF-8 flag of STRING is turned on. |
190 | |
191 | =back |
192 | |
193 | =head2 Testing For UTF-8 |
194 | |
195 | =over 4 |
196 | |
197 | =item * |
198 | |
199 | is_utf8(STRING [, CHECK]) |
200 | |
201 | [INTERNAL] Test whether the UTF-8 flag is turned on in the STRING. |
202 | If CHECK is true, also checks the data in STRING for being |
203 | well-formed UTF-8. Returns true if successful, false otherwise. |
204 | |
205 | =back |
206 | |
207 | =head2 Toggling UTF-8-ness |
208 | |
209 | =over 4 |
210 | |
211 | =item * |
212 | |
213 | on_utf8(STRING) |
214 | |
215 | [INTERNAL] Turn on the UTF-8 flag in STRING. The data in STRING is |
216 | B<not> checked for being well-formed UTF-8. Do not use unless you |
217 | B<know> that the STRING is well-formed UTF-8. Returns the previous |
218 | state of the UTF-8 flag (so please don't test the return value as |
219 | I<not> success or failure), or C<undef> if STRING is not a string. |
220 | |
221 | =item * |
222 | |
223 | off_utf8(STRING) |
224 | |
225 | [INTERNAL] Turn off the UTF-8 flag in STRING. Do not use frivolously. |
226 | Returns the previous state of the UTF-8 flag (so please don't test the |
227 | return value as I<not> success or failure), or C<undef> if STRING is |
228 | not a string. |
229 | |
230 | =back |
231 | |
232 | =head2 UTF-16 and UTF-32 Encodings |
233 | |
234 | =over 4 |
235 | |
236 | =item * |
237 | |
238 | utf_to_utf(STRING, FROM, TO [, CHECK]) |
239 | |
240 | The data in STRING is converted from Unicode Transfer Encoding FROM to |
241 | Unicode Transfer Encoding TO. Both FROM and TO may be any of the |
242 | following tags (case-insensitive, with or without 'utf' or 'utf-' prefix): |
243 | |
244 | tag meaning |
245 | |
246 | '7' UTF-7 |
247 | '8' UTF-8 |
248 | '16be' UTF-16 big-endian |
249 | '16le' UTF-16 little-endian |
250 | '16' UTF-16 native-endian |
251 | '32be' UTF-32 big-endian |
252 | '32le' UTF-32 little-endian |
253 | '32' UTF-32 native-endian |
254 | |
255 | UTF-16 is also known as UCS-2, 16 bit or 2-byte chunks, and UTF-32 as |
256 | UCS-4, 32-bit or 4-byte chunks. Returns the new size of STRING, or |
257 | C<undef> is there's a failure. |
258 | |
259 | If FROM is UTF-8 and the UTF-8 in STRING is malformed? See |
260 | L</"Handling Malformed Data">. |
261 | |
262 | [INTERNAL] Even if CHECK is true and FROM is UTF-8, the UTF-8 flag of |
263 | STRING is not checked. If TO is UTF-8, also the UTF-8 flag of STRING is |
264 | turned on. Identical FROM and TO are fine. |
265 | |
266 | =back |
267 | |
268 | =head2 Handling Malformed Data |
269 | |
270 | If CHECK is not set, C<undef> is returned. If the data is supposed to |
271 | be UTF-8, an optional lexical warning (category utf8) is given. If |
272 | CHECK is true but not a code reference, dies. If CHECK is a code |
273 | reference, it is called with the arguments |
274 | |
275 | (MALFORMED_STRING, STRING_FROM_SO_FAR, STRING_TO_SO_FAR) |
276 | |
277 | Two return values are expected from the call: the string to be used in |
278 | the result string in place of the malformed section, and the length of |
279 | the malformed section in bytes. |
280 | |
281 | =cut |
282 | |
283 | sub bytes_to_utf8 { |
284 | &_bytes_to_utf8; |
285 | } |
286 | |
287 | sub utf8_to_bytes { |
288 | &_utf8_to_bytes; |
289 | } |
290 | |
291 | sub chars_to_utf8 { |
292 | &C_to_utf8; |
293 | } |
294 | |
295 | sub utf8_to_chars { |
296 | &_utf8_to_chars; |
297 | } |
298 | |
299 | sub utf8_to_chars_check { |
300 | &_utf8_to_chars_check; |
301 | } |
302 | |
303 | sub bytes_to_chars { |
304 | &_bytes_to_chars; |
305 | } |
306 | |
307 | sub chars_to_bytes { |
308 | &_chars_to_bytes; |
309 | } |
310 | |
2c674647 |
311 | sub is_utf8 { |
312 | &_is_utf8; |
313 | } |
314 | |
315 | sub on_utf8 { |
316 | &_on_utf8; |
317 | } |
318 | |
319 | sub off_utf8 { |
320 | &_off_utf8; |
321 | } |
322 | |
323 | sub utf_to_utf { |
324 | &_utf_to_utf; |
325 | } |
326 | |
bf230f3d |
327 | use Carp; |
328 | |
656753f8 |
329 | sub from_to |
330 | { |
331 | my ($string,$from,$to,$check) = @_; |
332 | my $f = __PACKAGE__->getEncoding($from); |
bf230f3d |
333 | croak("Unknown encoding '$from'") unless $f; |
656753f8 |
334 | my $t = __PACKAGE__->getEncoding($to); |
bf230f3d |
335 | croak("Unknown encoding '$to'") unless $t; |
656753f8 |
336 | my $uni = $f->toUnicode($string,$check); |
bf230f3d |
337 | return undef if ($check && length($string)); |
656753f8 |
338 | $string = $t->fromUnicode($uni,$check); |
bf230f3d |
339 | return undef if ($check && length($uni)); |
656753f8 |
340 | return length($_[0] = $string); |
341 | } |
342 | |
343 | sub encodings |
344 | { |
345 | my ($class) = @_; |
346 | my ($dir) = __FILE__ =~ /^(.*)\.pm$/; |
347 | my @names = ('Unicode'); |
348 | if (opendir(my $dh,$dir)) |
349 | { |
350 | while (defined(my $name = readdir($dh))) |
351 | { |
352 | push(@names,$1) if ($name =~ /^(.*)\.enc$/); |
353 | } |
354 | closedir($dh); |
355 | } |
356 | else |
357 | { |
358 | die "Cannot open $dir:$!"; |
359 | } |
360 | return @names; |
361 | } |
362 | |
363 | my %encoding = ( Unicode => 'Encode::Unicode' ); |
364 | |
365 | sub getEncoding |
366 | { |
367 | my ($class,$name) = @_; |
368 | unless (exists $encoding{$name}) |
369 | { |
bf230f3d |
370 | my $file; |
371 | foreach my $dir (@INC) |
372 | { |
373 | last if -f ($file = "$dir/Encode/$name.enc"); |
374 | } |
656753f8 |
375 | if (open(my $fh,$file)) |
376 | { |
377 | my $type; |
378 | while (1) |
379 | { |
380 | my $line = <$fh>; |
381 | $type = substr($line,0,1); |
382 | last unless $type eq '#'; |
383 | } |
384 | $class .= ('::'.(($type eq 'E') ? 'Escape' : 'Table')); |
385 | $encoding{$name} = $class->read($fh,$name,$type); |
386 | } |
387 | } |
bf230f3d |
388 | return $encoding{$name}; |
656753f8 |
389 | } |
390 | |
391 | package Encode::Unicode; |
392 | |
393 | # Dummy package that provides the encode interface |
394 | |
395 | sub name { 'Unicode' } |
396 | |
397 | sub toUnicode { $_[1] } |
398 | |
399 | sub fromUnicode { $_[1] } |
400 | |
401 | package Encode::Table; |
402 | |
403 | sub read |
404 | { |
405 | my ($class,$fh,$name,$type) = @_; |
406 | my $rep = $class->can("rep_$type"); |
407 | my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>)); |
408 | my @touni; |
409 | my %fmuni; |
410 | my $count = 0; |
411 | $def = hex($def); |
412 | $def = pack(&$rep($def),$def); |
413 | while ($pages--) |
414 | { |
415 | my $page = hex(<$fh>); |
416 | my @page; |
417 | my $ch = $page * 256; |
418 | for (my $i = 0; $i < 16; $i++) |
419 | { |
420 | my $line = <$fh>; |
421 | for (my $j = 0; $j < 16; $j++) |
422 | { |
423 | my $val = hex(substr($line,0,4,'')); |
424 | if ($val || !$ch) |
425 | { |
426 | my $uch = chr($val); |
427 | push(@page,$uch); |
428 | $fmuni{$uch} = pack(&$rep($ch),$ch); |
429 | $count++; |
430 | } |
431 | else |
432 | { |
433 | push(@page,undef); |
434 | } |
435 | $ch++; |
436 | } |
437 | } |
438 | $touni[$page] = \@page; |
439 | } |
440 | |
441 | return bless {Name => $name, |
442 | Rep => $rep, |
443 | ToUni => \@touni, |
444 | FmUni => \%fmuni, |
445 | Def => $def, |
446 | Num => $count, |
447 | },$class; |
448 | } |
449 | |
450 | sub name { shift->{'Name'} } |
451 | |
452 | sub rep_S { 'C' } |
453 | |
454 | sub rep_D { 'S' } |
455 | |
456 | sub rep_M { ($_[0] > 255) ? 'S' : 'C' } |
457 | |
458 | sub representation |
459 | { |
460 | my ($obj,$ch) = @_; |
461 | $ch = 0 unless @_ > 1; |
462 | $obj-{'Rep'}->($ch); |
463 | } |
464 | |
465 | sub toUnicode |
466 | { |
bf230f3d |
467 | my ($obj,$str,$chk) = @_; |
656753f8 |
468 | my $rep = $obj->{'Rep'}; |
469 | my $touni = $obj->{'ToUni'}; |
470 | my $uni = ''; |
471 | while (length($str)) |
472 | { |
473 | my $ch = ord(substr($str,0,1,'')); |
bf230f3d |
474 | my $x; |
656753f8 |
475 | if (&$rep($ch) eq 'C') |
476 | { |
bf230f3d |
477 | $x = $touni->[0][$ch]; |
656753f8 |
478 | } |
479 | else |
480 | { |
bf230f3d |
481 | $x = $touni->[$ch][ord(substr($str,0,1,''))]; |
656753f8 |
482 | } |
bf230f3d |
483 | unless (defined $x) |
484 | { |
485 | last if $chk; |
486 | # What do we do here ? |
487 | $x = ''; |
488 | } |
489 | $uni .= $x; |
656753f8 |
490 | } |
bf230f3d |
491 | $_[1] = $str if $chk; |
656753f8 |
492 | return $uni; |
493 | } |
494 | |
495 | sub fromUnicode |
496 | { |
bf230f3d |
497 | my ($obj,$uni,$chk) = @_; |
656753f8 |
498 | my $fmuni = $obj->{'FmUni'}; |
499 | my $str = ''; |
500 | my $def = $obj->{'Def'}; |
501 | while (length($uni)) |
502 | { |
503 | my $ch = substr($uni,0,1,''); |
504 | my $x = $fmuni->{$ch}; |
bf230f3d |
505 | unless (defined $x) |
506 | { |
507 | last if ($chk); |
508 | $x = $def; |
509 | } |
510 | $str .= $x; |
656753f8 |
511 | } |
bf230f3d |
512 | $_[1] = $uni if $chk; |
656753f8 |
513 | return $str; |
514 | } |
515 | |
516 | package Encode::Escape; |
517 | use Carp; |
518 | |
519 | sub read |
520 | { |
521 | my ($class,$fh,$name) = @_; |
522 | my %self = (Name => $name, Num => 0); |
523 | while (<$fh>) |
524 | { |
525 | my ($key,$val) = /^(\S+)\s+(.*)$/; |
526 | $val =~ s/^\{(.*?)\}/$1/g; |
527 | $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge; |
528 | $self{$key} = $val; |
529 | } |
530 | return bless \%self,$class; |
531 | } |
532 | |
533 | sub name { shift->{'Name'} } |
534 | |
535 | sub toUnicode |
536 | { |
537 | croak("Not implemented yet"); |
538 | } |
539 | |
540 | sub fromUnicode |
541 | { |
542 | croak("Not implemented yet"); |
543 | } |
544 | |
545 | 1; |
546 | |
547 | __END__ |