← Back to branch summary

~ubuntu-branches/ubuntu/raring/libencode-perl/raring-proposed

« back to all changes in this revision

Viewing changes to t/Unicode.t

  • Committer: Bazaar Package Importer
  • Author(s): Jose Luis Rivas
  • Date: 2007-05-18 23:49:27 UTC
  • Revision ID: james.westby@ubuntu.com-20070518234927-bs37c807cty7i1ny
Tags: upstream-2.21
Import upstream version 2.21

Show diffs side-by-side

added added

removed removed

Lines of Context:
t/Unicode.t
 
1
#
 
2
# $Id: Unicode.t,v 2.1 2006/05/03 18:24:10 dankogai Exp $
 
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
    if (ord("A") == 193) {
 
15
        print "1..0 # Skip: EBCDIC\n";
 
16
    exit 0;
 
17
    }
 
18
    $| = 1;
 
19
}
 
20
 
 
21
use strict;
 
22
#use Test::More 'no_plan';
 
23
use Test::More tests => 37;
 
24
use Encode qw(encode decode);
 
25
 
 
26
#
 
27
# see
 
28
# http://www.unicode.org/unicode/reports/tr19/
 
29
#
 
30
 
 
31
my $dankogai   = "\x{5c0f}\x{98fc}\x{3000}\x{5f3e}";
 
32
my $nasty      = "$dankogai\x{1abcd}";
 
33
my $fallback   = "$dankogai\x{fffd}";
 
34
 
 
35
#hi: (0x1abcd - 0x10000) / 0x400 + 0xD800 = 0xd82a
 
36
#lo: (0x1abcd - 0x10000) % 0x400 + 0xDC00 = 0xdfcd
 
37
 
 
38
my $n_16be = 
 
39
    pack("C*", map {hex($_)} qw<5c 0f 98 fc 30 00 5f 3e  d8 2a df cd>);
 
40
my $n_16le =
 
41
    pack("C*", map {hex($_)} qw<0f 5c fc 98 00 30 3e 5f  2a d8 cd df>);
 
42
my $f_16be = 
 
43
    pack("C*", map {hex($_)} qw<5c 0f 98 fc 30 00 5f 3e  ff fd>);
 
44
my $f_16le =
 
45
    pack("C*", map {hex($_)} qw<0f 5c fc 98 00 30 3e 5f  fd ff>);
 
46
my $n_32be =
 
47
    pack("C*", map {hex($_)} 
 
48
     qw<00 00 5c 0f 00 00 98 fc 00 00 30 00 00 00 5f 3e  00 01 ab cd>);
 
49
my $n_32le = 
 
50
    pack("C*", map {hex($_)} 
 
51
     qw<0f 5c 00 00 fc 98 00 00 00 30 00 00 3e 5f 00 00  cd ab 01 00>);
 
52
 
 
53
my $n_16bb = pack('n', 0xFeFF) . $n_16be;
 
54
my $n_16lb = pack('v', 0xFeFF) . $n_16le;
 
55
my $n_32bb = pack('N', 0xFeFF) . $n_32be;
 
56
my $n_32lb = pack('V', 0xFeFF) . $n_32le;
 
57
 
 
58
is($n_16be, encode('UTF-16BE', $nasty),  qq{encode UTF-16BE});
 
59
is($n_16le, encode('UTF-16LE', $nasty),  qq{encode UTF-16LE});
 
60
is($n_32be, encode('UTF-32BE', $nasty),  qq{encode UTF-32BE});
 
61
is($n_32le, encode('UTF-32LE', $nasty),  qq{encode UTF-16LE});
 
62
 
 
63
is($nasty,  decode('UTF-16BE', $n_16be), qq{decode UTF-16BE});
 
64
is($nasty,  decode('UTF-16LE', $n_16le), qq{decode UTF-16LE});
 
65
is($nasty,  decode('UTF-32BE', $n_32be), qq{decode UTF-32BE});
 
66
is($nasty,  decode('UTF-32LE', $n_32le), qq{decode UTF-32LE});
 
67
 
 
68
is($n_16bb, encode('UTF-16',   $nasty),  qq{encode UTF-16});
 
69
is($n_32bb, encode('UTF-32',   $nasty),  qq{encode UTF-32});
 
70
is($nasty,  decode('UTF-16',   $n_16bb), qq{decode UTF-16, bom=be});
 
71
is($nasty,  decode('UTF-16',   $n_16lb), qq{decode UTF-16, bom=le});
 
72
is($nasty,  decode('UTF-32',   $n_32bb), qq{decode UTF-32, bom=be});
 
73
is($nasty,  decode('UTF-32',   $n_32lb), qq{decode UTF-32, bom=le});
 
74
 
 
75
is(decode('UCS-2BE', $n_16be), $fallback, "decode UCS-2BE: fallback");
 
76
is(decode('UCS-2LE', $n_16le), $fallback, "decode UCS-2LE: fallback");
 
77
eval { decode('UCS-2BE', $n_16be, 1) }; 
 
78
is (index($@,'UCS-2BE:'), 0, "decode UCS-2BE: exception");
 
79
eval { decode('UCS-2LE', $n_16le, 1) };
 
80
is (index($@,'UCS-2LE:'), 0, "decode UCS-2LE: exception");
 
81
is(encode('UCS-2BE', $nasty), $f_16be, "encode UCS-2BE: fallback");
 
82
is(encode('UCS-2LE', $nasty), $f_16le, "encode UCS-2LE: fallback");
 
83
eval { encode('UCS-2BE', $nasty, 1) }; 
 
84
is(index($@, 'UCS-2BE'), 0, "encode UCS-2BE: exception");
 
85
eval { encode('UCS-2LE', $nasty, 1) }; 
 
86
is(index($@, 'UCS-2LE'), 0, "encode UCS-2LE: exception");
 
87
 
 
88
#
 
89
# SvGROW test for (en|de)code_xs
 
90
#
 
91
SKIP: {
 
92
    my $utf8 = '';
 
93
    for my $j (0,0x10){
 
94
    for my $i (0..0xffff){
 
95
        $j == 0 and (0xD800 <= $i && $i <= 0xDFFF) and next;
 
96
        $utf8 .= ord($j+$i);
 
97
    }
 
98
    for my $major ('UTF-16', 'UTF-32'){
 
99
        for my $minor ('BE', 'LE'){
 
100
        my $enc = $major.$minor;
 
101
        is(decode($enc, encode($enc, $utf8)), $utf8, "$enc RT");
 
102
        }
 
103
    }
 
104
    }
 
105
};
 
106
 
 
107
#
 
108
# CJKT vs. UTF-7
 
109
#
 
110
 
 
111
use File::Spec;
 
112
use File::Basename;
 
113
 
 
114
my $dir =  dirname(__FILE__);
 
115
opendir my $dh, $dir or die "$dir:$!";
 
116
my @file = sort grep {/\.utf$/o} readdir $dh;
 
117
closedir $dh;
 
118
for my $file (@file){
 
119
    my $path = File::Spec->catfile($dir, $file);
 
120
    open my $fh, '<', $path or die "$path:$!";
 
121
    my $content;
 
122
    if (PerlIO::Layer->find('perlio')){
 
123
    binmode $fh => ':utf8';
 
124
    $content = join('' => <$fh>);
 
125
    }else{ # ugh!
 
126
    binmode $fh;
 
127
    $content = join('' => <$fh>);
 
128
    Encode::_utf8_on($content)
 
129
    }
 
130
    close $fh;
 
131
    is(decode("UTF-7", encode("UTF-7", $content)), $content, 
 
132
       "UTF-7 RT:$file");
 
133
}
 
134
1;
 
135
__END__