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 | |
87714904 |
363 | my %encoding = ( Unicode => bless({},'Encode::Unicode'), |
364 | 'iso10646-1' => bless({},'Encode::iso10646_1'), |
365 | ); |
656753f8 |
366 | |
367 | sub getEncoding |
368 | { |
369 | my ($class,$name) = @_; |
370 | unless (exists $encoding{$name}) |
371 | { |
bf230f3d |
372 | my $file; |
373 | foreach my $dir (@INC) |
374 | { |
375 | last if -f ($file = "$dir/Encode/$name.enc"); |
376 | } |
656753f8 |
377 | if (open(my $fh,$file)) |
378 | { |
379 | my $type; |
380 | while (1) |
381 | { |
382 | my $line = <$fh>; |
383 | $type = substr($line,0,1); |
384 | last unless $type eq '#'; |
385 | } |
386 | $class .= ('::'.(($type eq 'E') ? 'Escape' : 'Table')); |
387 | $encoding{$name} = $class->read($fh,$name,$type); |
388 | } |
87714904 |
389 | else |
390 | { |
391 | $encoding{$name} = undef; |
392 | } |
656753f8 |
393 | } |
bf230f3d |
394 | return $encoding{$name}; |
656753f8 |
395 | } |
396 | |
397 | package Encode::Unicode; |
398 | |
399 | # Dummy package that provides the encode interface |
400 | |
401 | sub name { 'Unicode' } |
402 | |
403 | sub toUnicode { $_[1] } |
404 | |
405 | sub fromUnicode { $_[1] } |
406 | |
407 | package Encode::Table; |
408 | |
409 | sub read |
410 | { |
411 | my ($class,$fh,$name,$type) = @_; |
412 | my $rep = $class->can("rep_$type"); |
413 | my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>)); |
414 | my @touni; |
415 | my %fmuni; |
416 | my $count = 0; |
417 | $def = hex($def); |
656753f8 |
418 | while ($pages--) |
419 | { |
87714904 |
420 | my $line = <$fh>; |
421 | chomp($line); |
422 | my $page = hex($line); |
656753f8 |
423 | my @page; |
424 | my $ch = $page * 256; |
425 | for (my $i = 0; $i < 16; $i++) |
426 | { |
427 | my $line = <$fh>; |
428 | for (my $j = 0; $j < 16; $j++) |
429 | { |
430 | my $val = hex(substr($line,0,4,'')); |
431 | if ($val || !$ch) |
432 | { |
433 | my $uch = chr($val); |
434 | push(@page,$uch); |
87714904 |
435 | $fmuni{$uch} = $ch; |
656753f8 |
436 | $count++; |
437 | } |
438 | else |
439 | { |
440 | push(@page,undef); |
441 | } |
442 | $ch++; |
443 | } |
444 | } |
445 | $touni[$page] = \@page; |
446 | } |
447 | |
448 | return bless {Name => $name, |
449 | Rep => $rep, |
450 | ToUni => \@touni, |
451 | FmUni => \%fmuni, |
452 | Def => $def, |
453 | Num => $count, |
454 | },$class; |
455 | } |
456 | |
457 | sub name { shift->{'Name'} } |
458 | |
459 | sub rep_S { 'C' } |
460 | |
461 | sub rep_D { 'S' } |
462 | |
463 | sub rep_M { ($_[0] > 255) ? 'S' : 'C' } |
464 | |
465 | sub representation |
466 | { |
467 | my ($obj,$ch) = @_; |
468 | $ch = 0 unless @_ > 1; |
469 | $obj-{'Rep'}->($ch); |
470 | } |
471 | |
472 | sub toUnicode |
473 | { |
bf230f3d |
474 | my ($obj,$str,$chk) = @_; |
656753f8 |
475 | my $rep = $obj->{'Rep'}; |
476 | my $touni = $obj->{'ToUni'}; |
477 | my $uni = ''; |
478 | while (length($str)) |
479 | { |
480 | my $ch = ord(substr($str,0,1,'')); |
bf230f3d |
481 | my $x; |
656753f8 |
482 | if (&$rep($ch) eq 'C') |
483 | { |
bf230f3d |
484 | $x = $touni->[0][$ch]; |
656753f8 |
485 | } |
486 | else |
487 | { |
bf230f3d |
488 | $x = $touni->[$ch][ord(substr($str,0,1,''))]; |
656753f8 |
489 | } |
bf230f3d |
490 | unless (defined $x) |
491 | { |
492 | last if $chk; |
493 | # What do we do here ? |
494 | $x = ''; |
495 | } |
496 | $uni .= $x; |
656753f8 |
497 | } |
bf230f3d |
498 | $_[1] = $str if $chk; |
656753f8 |
499 | return $uni; |
500 | } |
501 | |
502 | sub fromUnicode |
503 | { |
bf230f3d |
504 | my ($obj,$uni,$chk) = @_; |
656753f8 |
505 | my $fmuni = $obj->{'FmUni'}; |
506 | my $str = ''; |
507 | my $def = $obj->{'Def'}; |
87714904 |
508 | my $rep = $obj->{'Rep'}; |
656753f8 |
509 | while (length($uni)) |
510 | { |
511 | my $ch = substr($uni,0,1,''); |
512 | my $x = $fmuni->{$ch}; |
bf230f3d |
513 | unless (defined $x) |
514 | { |
515 | last if ($chk); |
516 | $x = $def; |
517 | } |
87714904 |
518 | $str .= pack(&$rep($x),$x); |
519 | } |
520 | $_[1] = $uni if $chk; |
521 | return $str; |
522 | } |
523 | |
524 | package Encode::iso10646_1;# |
525 | |
526 | sub name { 'iso10646-1' } |
527 | |
528 | sub toUnicode |
529 | { |
530 | my ($obj,$str,$chk) = @_; |
531 | my $uni = ''; |
532 | while (length($str)) |
533 | { |
534 | my $code = unpack('S',substr($str,0,2,'')); |
535 | $uni .= chr($code); |
536 | } |
537 | $_[1] = $str if $chk; |
538 | return $uni; |
539 | } |
540 | |
541 | sub fromUnicode |
542 | { |
543 | my ($obj,$uni,$chk) = @_; |
544 | my $str = ''; |
545 | while (length($uni)) |
546 | { |
547 | my $ch = substr($uni,0,1,''); |
548 | my $x = ord($ch); |
549 | unless ($x < 32768) |
550 | { |
551 | last if ($chk); |
552 | $x = 0; |
553 | } |
554 | $str .= pack('S',$x); |
656753f8 |
555 | } |
bf230f3d |
556 | $_[1] = $uni if $chk; |
656753f8 |
557 | return $str; |
558 | } |
559 | |
560 | package Encode::Escape; |
561 | use Carp; |
562 | |
563 | sub read |
564 | { |
565 | my ($class,$fh,$name) = @_; |
566 | my %self = (Name => $name, Num => 0); |
567 | while (<$fh>) |
568 | { |
569 | my ($key,$val) = /^(\S+)\s+(.*)$/; |
570 | $val =~ s/^\{(.*?)\}/$1/g; |
571 | $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge; |
572 | $self{$key} = $val; |
573 | } |
574 | return bless \%self,$class; |
575 | } |
576 | |
577 | sub name { shift->{'Name'} } |
578 | |
579 | sub toUnicode |
580 | { |
581 | croak("Not implemented yet"); |
582 | } |
583 | |
584 | sub fromUnicode |
585 | { |
586 | croak("Not implemented yet"); |
587 | } |
588 | |
589 | 1; |
590 | |
591 | __END__ |