ext/Encode/t/Unicode.t

   1 #
   2 # $Id: jperl.t,v 1.20 2002/04/04 19:50:52 dankogai Exp $
   3 #
   4 # This script is written in euc-jp
   5
   6 BEGIN {
   7     require Config; import Config;
   8     if ($Config{'extensions'} !~ /\bEncode\b/) {
   9       print "1..0 # Skip: Encode was not built\n";
  10       exit 0;
  11     }
  12 # should work without perlio
  13 #     unless (find PerlIO::Layer 'perlio') {
  14 #      print "1..0 # Skip: PerlIO was not built\n";
  15 #      exit 0;
  16 #     }
  17 # should work on EBCDIC
  18 #    if (ord("A") == 193) {
  19 #      print "1..0 # Skip: EBCDIC\n";
  20 #      exit 0;
  21 #    }
  22     $| = 1;
  23 }
  24
  25 use strict;
  26 #use Test::More 'no_plan';
  27 use Test::More tests => 22;
  28 use Encode qw(encode decode);
  29 use Encode::utflib;
  30
  31 #
  32 # see
  33 # http://www.unicode.org/unicode/reports/tr19/
  34 #
  35
  36 my $nasty      = "\x{004D}\x{0061}\x{1abcd}";
  37 my $fallback   = "\x{004D}\x{0061}\x{fffd}";
  38
  39 #hi: (0x1abcd - 0x10000) / 0x400 + 0xD800 = 0xd82a
  40 #lo: (0x1abcd - 0x10000) % 0x400 + 0xDC00 = 0xdfcd
  41
  42 my $n_16be =
  43     pack("C*", map {hex($_)} qw<00 4D 00 61 d8 2a df cd>);
  44 my $n_16le =
  45     pack("C*", map {hex($_)} qw<4D 00 61 00 2a d8 cd df>);
  46 my $f_16be =
  47     pack("C*", map {hex($_)} qw<00 4D 00 61 ff fd>);
  48 my $f_16le =
  49     pack("C*", map {hex($_)} qw<4D 00 61 00 fd ff>);
  50 my $n_32be =
  51     pack("C*", map {hex($_)} qw<00 00 00 4D 00 00 00 61 00 01 ab cd>);
  52 my $n_32le =
  53     pack("C*", map {hex($_)} qw<4D 00 00 00 61 00 00 00 cd ab 01 00>);
  54
  55 my $n_16bb = pack('n', BOM_BE)  . $n_16be;
  56 my $n_16lb = pack('n', BOM16LE) . $n_16le;
  57 my $n_32bb = pack('N', BOM_BE ) . $n_32be;
  58 my $n_32lb = pack('N', BOM32LE) . $n_32le;
  59
  60 is($n_16be, encode('UTF-16BE', $nasty),  qq{encode UTF-16BE});
  61 is($n_16le, encode('UTF-16LE', $nasty),  qq{encode UTF-16LE});
  62 is($n_32be, encode('UTF-32BE', $nasty),  qq{encode UTF-32BE});
  63 is($n_32le, encode('UTF-32LE', $nasty),  qq{encode UTF-16LE});
  64
  65 is($nasty,  decode('UTF-16BE', $n_16be), qq{decode UTF-16BE});
  66 is($nasty,  decode('UTF-16LE', $n_16le), qq{decode UTF-16LE});
  67 is($nasty,  decode('UTF-32BE', $n_32be), qq{decode UTF-32BE});
  68 is($nasty,  decode('UTF-32LE', $n_32le), qq{decode UTF-32LE});
  69
  70 is($n_16bb, encode('UTF-16',   $nasty),  qq{encode UTF-16});
  71 is($n_32bb, encode('UTF-32',   $nasty),  qq{encode UTF-32});
  72 is($nasty,  decode('UTF-16',   $n_16bb), qq{decode UTF-16, bom=be});
  73 is($nasty,  decode('UTF-16',   $n_16lb), qq{decode UTF-16, bom=le});
  74 is($nasty,  decode('UTF-32',   $n_32bb), qq{decode UTF-32, bom=be});
  75 is($nasty,  decode('UTF-32',   $n_32lb), qq{decode UTF-32, bom=le});
  76
  77 is(decode('UCS-2BE', $n_16be), $fallback, "decode UCS-2BE: fallback");
  78 is(decode('UCS-2LE', $n_16le), $fallback, "decode UCS-2LE: fallback");
  79 eval { decode('UCS-2BE', $n_16be, 1) };
  80 ok($@=~/^UCS-2BE:/, "decode UCS-2BE: exception");
  81 eval { decode('UCS-2LE', $n_16le, 1) };
  82 ok($@=~/^UCS-2LE:/, "decode UCS-2LE: exception");
  83 is(encode('UCS-2BE', $nasty), $f_16be, "encode UCS-2BE: fallback");
  84 is(encode('UCS-2LE', $nasty), $f_16le, "encode UCS-2LE: fallback");
  85 eval { encode('UCS-2BE', $nasty, 1) };
  86 ok($@=~/^UCS-2BE:/, "encode UCS-2BE: exception");
  87 eval { encode('UCS-2LE', $nasty, 1) };
  88 ok($@=~/^UCS-2LE:/, "encode UCS-2LE: exception");
  89
  90 1;
  91 __END__
  92
  93 use Devel::Peek;
  94 my $foo = decode('UTF-16BE', $n_16be);
  95 Dump $n_16be; Dump $foo;
  96 #
  97 # $Id: jperl.t,v 1.20 2002/04/04 19:50:52 dankogai Exp $
  98 #
  99 # This script is written in euc-jp
 100
 101 BEGIN {
 102     require Config; import Config;
 103     if ($Config{'extensions'} !~ /\bEncode\b/) {
 104       print "1..0 # Skip: Encode was not built\n";
 105       exit 0;
 106     }
 107 # should work without perlio
 108 #     unless (find PerlIO::Layer 'perlio') {
 109 #      print "1..0 # Skip: PerlIO was not built\n";
 110 #      exit 0;
 111 #     }
 112 # should work on EBCDIC
 113 #    if (ord("A") == 193) {
 114 #      print "1..0 # Skip: EBCDIC\n";
 115 #      exit 0;
 116 #    }
 117     $| = 1;
 118 }
 119
 120 use strict;
 121 #use Test::More 'no_plan';
 122 use Test::More tests => 22;
 123 use Encode qw(encode decode);
 124 use Encode::utflib;
 125
 126 #
 127 # see
 128 # http://www.unicode.org/unicode/reports/tr19/
 129 #
 130
 131 my $nasty      = "\x{004D}\x{0061}\x{1abcd}";
 132 my $fallback   = "\x{004D}\x{0061}\x{fffd}";
 133
 134 #hi: (0x1abcd - 0x10000) / 0x400 + 0xD800 = 0xd82a
 135 #lo: (0x1abcd - 0x10000) % 0x400 + 0xDC00 = 0xdfcd
 136
 137 my $n_16be =
 138     pack("C*", map {hex($_)} qw<00 4D 00 61 d8 2a df cd>);
 139 my $n_16le =
 140     pack("C*", map {hex($_)} qw<4D 00 61 00 2a d8 cd df>);
 141 my $f_16be =
 142     pack("C*", map {hex($_)} qw<00 4D 00 61 ff fd>);
 143 my $f_16le =
 144     pack("C*", map {hex($_)} qw<4D 00 61 00 fd ff>);
 145 my $n_32be =
 146     pack("C*", map {hex($_)} qw<00 00 00 4D 00 00 00 61 00 01 ab cd>);
 147 my $n_32le =
 148     pack("C*", map {hex($_)} qw<4D 00 00 00 61 00 00 00 cd ab 01 00>);
 149
 150 my $n_16bb = pack('n', BOM_BE)  . $n_16be;
 151 my $n_16lb = pack('n', BOM16LE) . $n_16le;
 152 my $n_32bb = pack('N', BOM_BE ) . $n_32be;
 153 my $n_32lb = pack('N', BOM32LE) . $n_32le;
 154
 155 is($n_16be, encode('UTF-16BE', $nasty),  qq{encode UTF-16BE});
 156 is($n_16le, encode('UTF-16LE', $nasty),  qq{encode UTF-16LE});
 157 is($n_32be, encode('UTF-32BE', $nasty),  qq{encode UTF-32BE});
 158 is($n_32le, encode('UTF-32LE', $nasty),  qq{encode UTF-16LE});
 159
 160 is($nasty,  decode('UTF-16BE', $n_16be), qq{decode UTF-16BE});
 161 is($nasty,  decode('UTF-16LE', $n_16le), qq{decode UTF-16LE});
 162 is($nasty,  decode('UTF-32BE', $n_32be), qq{decode UTF-32BE});
 163 is($nasty,  decode('UTF-32LE', $n_32le), qq{decode UTF-32LE});
 164
 165 is($n_16bb, encode('UTF-16',   $nasty),  qq{encode UTF-16});
 166 is($n_32bb, encode('UTF-32',   $nasty),  qq{encode UTF-32});
 167 is($nasty,  decode('UTF-16',   $n_16bb), qq{decode UTF-16, bom=be});
 168 is($nasty,  decode('UTF-16',   $n_16lb), qq{decode UTF-16, bom=le});
 169 is($nasty,  decode('UTF-32',   $n_32bb), qq{decode UTF-32, bom=be});
 170 is($nasty,  decode('UTF-32',   $n_32lb), qq{decode UTF-32, bom=le});
 171
 172 is(decode('UCS-2BE', $n_16be), $fallback, "decode UCS-2BE: fallback");
 173 is(decode('UCS-2LE', $n_16le), $fallback, "decode UCS-2LE: fallback");
 174 eval { decode('UCS-2BE', $n_16be, 1) };
 175 ok($@=~/^UCS-2BE:/, "decode UCS-2BE: exception");
 176 eval { decode('UCS-2LE', $n_16le, 1) };
 177 ok($@=~/^UCS-2LE:/, "decode UCS-2LE: exception");
 178 is(encode('UCS-2BE', $nasty), $f_16be, "encode UCS-2BE: fallback");
 179 is(encode('UCS-2LE', $nasty), $f_16le, "encode UCS-2LE: fallback");
 180 eval { encode('UCS-2BE', $nasty, 1) };
 181 ok($@=~/^UCS-2BE:/, "encode UCS-2BE: exception");
 182 eval { encode('UCS-2LE', $nasty, 1) };
 183 ok($@=~/^UCS-2LE:/, "encode UCS-2LE: exception");
 184
 185 1;
 186 __END__
 187
 188 use Devel::Peek;
 189 my $foo = decode('UTF-16BE', $n_16be);
 190 Dump $n_16be; Dump $foo;