ext/Encode/t/Unicode.t

   1 #
   2 # $Id: Unicode.t,v 1.4 2002/04/08 02:35:48 dankogai Exp dankogai $
   3 #
   4 # This script is written entirely in ASCII, even though quoted literals
   5 # do include non-BMP unicode characters -- Are you happy, jhi?
   6 #
   7
   8 BEGIN {
   9     require Config; import Config;
  10     if ($Config{'extensions'} !~ /\bEncode\b/) {
  11       print "1..0 # Skip: Encode was not built\n";
  12       exit 0;
  13     }
  14 # should work without perlio
  15 #     unless (find PerlIO::Layer 'perlio') {
  16 #       print "1..0 # Skip: PerlIO was not built\n";
  17 #       exit 0;
  18 #     }
  19 # should work on EBCDIC
  20 #    if (ord("A") == 193) {
  21 #       print "1..0 # Skip: EBCDIC\n";
  22 #       exit 0;
  23 #    }
  24     $| = 1;
  25 }
  26
  27 use strict;
  28 #use Test::More 'no_plan';
  29 use Test::More tests => 22;
  30 use Encode qw(encode decode);
  31 use Encode::Unicode; # to load BOM defs
  32
  33 #
  34 # see
  35 # http://www.unicode.org/unicode/reports/tr19/
  36 #
  37
  38 my $nasty      = "\x{004D}\x{0061}\x{1abcd}";
  39 my $fallback   = "\x{004D}\x{0061}\x{fffd}";
  40
  41 #hi: (0x1abcd - 0x10000) / 0x400 + 0xD800 = 0xd82a
  42 #lo: (0x1abcd - 0x10000) % 0x400 + 0xDC00 = 0xdfcd
  43
  44 my $n_16be =
  45     pack("C*", map {hex($_)} qw<00 4D 00 61 d8 2a df cd>);
  46 my $n_16le =
  47     pack("C*", map {hex($_)} qw<4D 00 61 00 2a d8 cd df>);
  48 my $f_16be =
  49     pack("C*", map {hex($_)} qw<00 4D 00 61 ff fd>);
  50 my $f_16le =
  51     pack("C*", map {hex($_)} qw<4D 00 61 00 fd ff>);
  52 my $n_32be =
  53     pack("C*", map {hex($_)} qw<00 00 00 4D 00 00 00 61 00 01 ab cd>);
  54 my $n_32le =
  55     pack("C*", map {hex($_)} qw<4D 00 00 00 61 00 00 00 cd ab 01 00>);
  56
  57 my $n_16bb = pack('n', Encode::Unicode::BOM_BE)  . $n_16be;
  58 my $n_16lb = pack('n', Encode::Unicode::BOM16LE) . $n_16le;
  59 my $n_32bb = pack('N', Encode::Unicode::BOM_BE ) . $n_32be;
  60 my $n_32lb = pack('N', Encode::Unicode::BOM32LE) . $n_32le;
  61
  62 is($n_16be, encode('UTF-16BE', $nasty),  qq{encode UTF-16BE});
  63 is($n_16le, encode('UTF-16LE', $nasty),  qq{encode UTF-16LE});
  64 is($n_32be, encode('UTF-32BE', $nasty),  qq{encode UTF-32BE});
  65 is($n_32le, encode('UTF-32LE', $nasty),  qq{encode UTF-16LE});
  66
  67 is($nasty,  decode('UTF-16BE', $n_16be), qq{decode UTF-16BE});
  68 is($nasty,  decode('UTF-16LE', $n_16le), qq{decode UTF-16LE});
  69 is($nasty,  decode('UTF-32BE', $n_32be), qq{decode UTF-32BE});
  70 is($nasty,  decode('UTF-32LE', $n_32le), qq{decode UTF-32LE});
  71
  72 is($n_16bb, encode('UTF-16',   $nasty),  qq{encode UTF-16});
  73 is($n_32bb, encode('UTF-32',   $nasty),  qq{encode UTF-32});
  74 is($nasty,  decode('UTF-16',   $n_16bb), qq{decode UTF-16, bom=be});
  75 is($nasty,  decode('UTF-16',   $n_16lb), qq{decode UTF-16, bom=le});
  76 is($nasty,  decode('UTF-32',   $n_32bb), qq{decode UTF-32, bom=be});
  77 is($nasty,  decode('UTF-32',   $n_32lb), qq{decode UTF-32, bom=le});
  78
  79 is(decode('UCS-2BE', $n_16be), $fallback, "decode UCS-2BE: fallback");
  80 is(decode('UCS-2LE', $n_16le), $fallback, "decode UCS-2LE: fallback");
  81 eval { decode('UCS-2BE', $n_16be, 1) };
  82 ok($@=~/^UCS-2BE:/, "decode UCS-2BE: exception");
  83 eval { decode('UCS-2LE', $n_16le, 1) };
  84 ok($@=~/^UCS-2LE:/, "decode UCS-2LE: exception");
  85 is(encode('UCS-2BE', $nasty), $f_16be, "encode UCS-2BE: fallback");
  86 is(encode('UCS-2LE', $nasty), $f_16le, "encode UCS-2LE: fallback");
  87 eval { encode('UCS-2BE', $nasty, 1) };
  88 ok($@=~/^UCS-2BE:/, "encode UCS-2BE: exception");
  89 eval { encode('UCS-2LE', $nasty, 1) };
  90 ok($@=~/^UCS-2LE:/, "encode UCS-2LE: exception");
  91
  92 1;
  93 __END__
  94
  95 use Devel::Peek;
  96 my $foo = decode('UTF-16BE', $n_16be);
  97 Dump $n_16be; Dump $foo;