/[suikacvs]/markup/html/whatpm/t/Charset-DecodeHandler.t
Suika

Contents of /markup/html/whatpm/t/Charset-DecodeHandler.t

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.1 - (hide annotations) (download) (as text)
Sun Jul 15 12:41:51 2007 UTC (19 years ago) by wakaba
Branch: MAIN
File MIME type: application/x-troff 
++ whatpm/t/ChangeLog	15 Jul 2007 12:41:07 -0000
2007-07-15  Wakaba  <wakaba@suika.fam.cx>

	* Charset-DecodeHandler.t: New test script.

++ whatpm/Whatpm/ChangeLog	15 Jul 2007 08:22:21 -0000
	* Charset/: New directory.

2007-07-15  Wakaba  <wakaba@suika.fam.cx>

++ whatpm/Whatpm/Charset/ChangeLog	15 Jul 2007 08:22:53 -0000
2007-07-15  Wakaba  <wakaba@suika.fam.cx>

	* DecodeHandle.pm: New Perl module (created
	from manakai's |Encode.dis|).

2007-07-15  Wakaba  <wakaba@suika.fam.cx>

	* ChangeLog: New file.
1 wakaba 1.1 #!/usr/bin/perl
2     use strict;
3     use Test;
4     BEGIN { plan tests => 6185 }
5    
6     require Whatpm::Charset::DecodeHandle;
7    
8     my $XML_AUTO_CHARSET = q<http://suika.fam.cx/www/2006/03/xml-entity/>;
9     my $IANA_CHARSET = q<urn:x-suika-fam-cx:charset:>;
10     my $PERL_CHARSET = q<http://suika.fam.cx/~wakaba/archive/2004/dis/Charset/Perl.>;
11     my $XML_CHARSET = q<http://suika.fam.cx/~wakaba/archive/2004/dis/Charset/XML.>;
12    
13     ## |create_decode_handle|
14     for my $test (
15     ['perl.utf8', $PERL_CHARSET.'utf8', 1],
16     ['xml', $XML_AUTO_CHARSET, 1],
17     ['unknown', q<http://www.unknown.test/>, 0],
18     ['iana.euc-jp', $IANA_CHARSET.'euc-jp', 1],
19     ['xml.euc-jp', $XML_CHARSET.'euc-jp', 1],
20     ['iana.shift_jis', $IANA_CHARSET.'shift_jis', 1],
21     ['xml.shift_jis', $XML_CHARSET.'shift_jis', 1],
22     ['iana.iso-2022-jp', $IANA_CHARSET.'iso-2022-jp', 1],
23     ['xml.iso-2022-jp', $XML_CHARSET.'iso-2022-jp', 1],
24     ) {
25     open my $fh, '<', \'';
26     my $dh = Whatpm::Charset::DecodeHandle->create_decode_handle ($test->[1], $fh);
27    
28     if ($test->[2]) {
29     ok UNIVERSAL::isa ($dh, 'Whatpm::Charset::DecodeHandle::Encode') ? 1 : 0, 1,
30     'create_decode_handle ' . $test->[0] . ' object';
31     ok ref $dh->onerror eq 'CODE' ? 1 : 0, 1,
32     'create_decode_handle ' . $test->[0] . ' onerror';
33     } else {
34     ok UNIVERSAL::isa ($dh, 'Whatpm::Charset::DecodeHandle::Encode') ? 1 : 0, 0,
35     'create_decode_handle ' . $test->[0] . ' object';
36    
37     Whatpm::Charset::DecodeHandle->create_decode_handle ($test->[1], $fh, sub {
38     ok $_[1], 'charset-not-supported-error',
39     'create_decode_handle ' . $test->[0] . ' error';
40     });
41     }
42     }
43    
44     ## |name_to_uri|
45     for (
46     [$IANA_CHARSET.'utf-8', 'utf-8'],
47     [$IANA_CHARSET.'x-no-such-charset', 'x-no-such-charset'],
48     [$IANA_CHARSET.'utf-8', 'UTF-8'],
49     [$IANA_CHARSET.'utf-8', 'uTf-8'],
50     [$IANA_CHARSET.'utf-16be', 'utf-16be'],
51     ) {
52     my $iname = Whatpm::Charset::DecodeHandle->name_to_uri (ietf => $_->[1]);
53     ok $iname, $_->[0], 'ietf charset URI ' . $_->[1];
54     }
55    
56     for (
57     [$XML_CHARSET.'utf-8', 'utf-8'],
58     [$XML_CHARSET.'x-no-such-charset', 'x-no-such-charset'],
59     [$XML_CHARSET.'utf-8', 'UTF-8'],
60     [$XML_CHARSET.'utf-8', 'uTf-8'],
61     [$IANA_CHARSET.'utf-16be', 'utf-16be'],
62     ) {
63     my $iname = Whatpm::Charset::DecodeHandle->name_to_uri (xml => $_->[1]);
64     ok $iname, $_->[0], 'XML encoding URI ' . $_->[1];
65     }
66    
67     ## |uri_to_name|
68     for (
69     [$IANA_CHARSET.'utf-8', 'utf-8'],
70     [$IANA_CHARSET.'x-no-such-charset', 'x-no-such-charset'],
71     [q<http://charset.example/>, undef],
72     ) {
73     my $uri = Whatpm::Charset::DecodeHandle->uri_to_name (ietf => $_->[0]);
74     ok $uri, $_->[1], 'URI -> IETF charset ' . $_->[0];
75     }
76    
77     for (
78     [$XML_CHARSET.'utf-8', 'utf-8'],
79     [$XML_CHARSET.'x-no-such-charset', 'x-no-such-charset'],
80     [q<http://charset.example/>, undef],
81     ) {
82     my $uri = Whatpm::Charset::DecodeHandle->uri_to_name (xml => $_->[0]);
83     ok $uri, $_->[1], 'URI -> XML encoding ' . $_->[0];
84     }
85    
86     ## |getc|
87     {
88     my $byte = "a\xE3\x81\x82\x81a";
89     open my $fh, '<', \$byte;
90     my $efh = Whatpm::Charset::DecodeHandle->create_decode_handle
91     ($PERL_CHARSET.'utf8', $fh);
92    
93     my $error;
94     $efh->onerror (sub {
95     my ($efh, $type, %opt) = @_;
96     $error = ${$opt{octets}};
97     });
98    
99     ok $efh->getc, "a", "getc 1 [1]";
100     ok $error, undef, "getc 1 [1] error";
101     ok $efh->getc, "\x{3042}", "getc 1 [2]";
102     ok $error, undef, "getc 1 [2] error";
103     ok $efh->getc, "\x81", "getc 1 [3]";
104     ok $error, "\x81", "getc 1 [3] error";
105     undef $error;
106     ok $efh->getc, "a", "getc 1 [4]";
107     ok $error, undef, "getc 1 [4] error";
108     ok $efh->getc, undef, "getc 1 [5]";
109     ok $error, undef, "getc 1 [5] error";
110     }
111    
112     {
113     my $byte = "a" x 256;
114     $byte .= "b" x 256;
115    
116     open my $fh, '<', \$byte;
117     my $efh = Whatpm::Charset::DecodeHandle->create_decode_handle
118     ($PERL_CHARSET.'utf8', $fh);
119    
120     my $error;
121     $efh->onerror (sub {
122     my ($efh, $type, %opt) = @_;
123     $error = ${$opt{octets}};
124     });
125    
126     for my $i (0..255) {
127     ok $efh->getc, "a", "getc 2 [$i]";
128     ok $error, undef, "getc 2 [$i] error";
129     }
130    
131     for my $i (0..255) {
132     ok $efh->getc, "b", "getc 2 [255+$i]";
133     ok $error, undef, "getc 2 [255+$i] error";
134     }
135    
136     ok $efh->getc, undef, "getc 2 [-1]";
137     ok $error, undef, "getc 2 [-1] error";
138     }
139    
140     {
141     my $byte = "a" x 255;
142     $byte .= "\xE3\x81\x82";
143     $byte .= "b" x 256;
144    
145     open my $fh, '<', \$byte;
146     my $efh = Whatpm::Charset::DecodeHandle->create_decode_handle
147     ($PERL_CHARSET.'utf8', $fh);
148    
149     my $error;
150     $efh->onerror (sub {
151     my ($efh, $type, %opt) = @_;
152   &