1#!../perl 2our $DEBUG = @ARGV; 3our (%ORD, %SEQ, $NTESTS); 4BEGIN { 5 if ($ENV{'PERL_CORE'}){ 6 chdir 't'; 7 unshift @INC, '../lib'; 8 } 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 ($] <= 5.008 and !$Config{perl_patchlevel}){ 15 print "1..0 # Skip: Perl 5.8.1 or later required\n"; 16 exit 0; 17 } 18 # http://smontagu.damowmow.com/utf8test.html 19 %ORD = ( 20 0x00000080 => 0, # 2.1.2 21 0x00000800 => 0, # 2.1.3 22 0x00010000 => 0, # 2.1.4 23 0x00200000 => 1, # 2.1.5 24 0x00400000 => 1, # 2.1.6 25 0x0000007F => 0, # 2.2.1 -- unmapped okay 26 0x000007FF => 0, # 2.2.2 27 0x0000FFFF => 1, # 2.2.3 28 0x001FFFFF => 1, # 2.2.4 29 0x03FFFFFF => 1, # 2.2.5 30 0x7FFFFFFF => 1, # 2.2.6 31 0x0000D800 => 1, # 5.1.1 32 0x0000DB7F => 1, # 5.1.2 33 0x0000D880 => 1, # 5.1.3 34 0x0000DBFF => 1, # 5.1.4 35 0x0000DC00 => 1, # 5.1.5 36 0x0000DF80 => 1, # 5.1.6 37 0x0000DFFF => 1, # 5.1.7 38 # 5.2 "Paird UTF-16 surrogates skipped 39 # because utf-8-strict raises exception at the first one 40 0x0000FFFF => 1, # 5.3.1 41 ); 42 $NTESTS += scalar keys %ORD; 43 if (ord('A') == 193) { 44 %SEQ = ( 45 qq/dd 64 73 73/ => 0, # 2.3.1 46 qq/dd 67 41 41/ => 0, # 2.3.2 47 qq/ee 42 73 73 73/ => 0, # 2.3.3 48 qq/f4 90 80 80/ => 1, # 2.3.4 -- out of range so NG 49 # "3 Malformed sequences" are checked by perl. 50 # "4 Overlong sequences" are checked by perl. 51 ); 52 } else { 53 %SEQ = ( 54 qq/ed 9f bf/ => 0, # 2.3.1 55 qq/ee 80 80/ => 0, # 2.3.2 56 qq/f4 8f bf bf/ => 0, # 2.3.3 57 qq/f4 90 80 80/ => 1, # 2.3.4 -- out of range so NG 58 # "3 Malformed sequences" are checked by perl. 59 # "4 Overlong sequences" are checked by perl. 60 ); 61 } 62 $NTESTS += scalar keys %SEQ; 63} 64use strict; 65use Encode; 66use utf8; 67use Test::More tests => $NTESTS; 68 69local($SIG{__WARN__}) = sub { $DEBUG and $@ and print STDERR $@ }; 70 71my $d = find_encoding("utf-8-strict"); 72for my $u (sort keys %ORD){ 73 my $c = chr($u); 74 eval { $d->encode($c,1) }; 75 $DEBUG and $@ and warn $@; 76 my $t = $@ ? 1 : 0; 77 is($t, $ORD{$u}, sprintf "U+%04X", $u); 78} 79for my $s (sort keys %SEQ){ 80 my $o = pack "C*" => map {hex} split /\s+/, $s; 81 eval { $d->decode($o,1) }; 82 $DEBUG and $@ and warn $@; 83 my $t = $@ ? 1 : 0; 84 is($t, $SEQ{$s}, $s); 85} 86 87__END__ 88 89 90