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