1#!./perl -w 2 3print "1..4216\n"; 4my $test = 0; 5 6my %templates = ( 7 'UTF-8' => 'C0U', 8 'UTF-16BE' => 'n', 9 'UTF-16LE' => 'v', 10 ); 11 12sub bytes_to_utf { 13 my ($enc, $content, $do_bom) = @_; 14 my $template = $templates{$enc}; 15 die "Unsupported encoding $enc" unless $template; 16 my @chars = unpack "U*", $content; 17 if ($enc ne 'UTF-8') { 18 # Make surrogate pairs 19 my @remember_that_utf_16_is_variable_length; 20 foreach my $ord (@chars) { 21 if ($ord < 0x10000) { 22 push @remember_that_utf_16_is_variable_length, 23 $ord; 24 } else { 25 $ord -= 0x10000; 26 push @remember_that_utf_16_is_variable_length, 27 (0xD800 | ($ord >> 10)), (0xDC00 | ($ord & 0x3FF)); 28 } 29 } 30 @chars = @remember_that_utf_16_is_variable_length; 31 } 32 return pack "$template*", ($do_bom ? 0xFEFF : ()), @chars; 33} 34 35sub test { 36 my ($enc, $write, $expect, $bom, $nl, $name) = @_; 37 open my $fh, ">", "tmputf$$.pl" or die "tmputf$$.pl: $!"; 38 binmode $fh; 39 print $fh bytes_to_utf($enc, $write . ($nl ? "\n" : ''), $bom); 40 close $fh or die $!; 41 my $got = do "./tmputf$$.pl"; 42 $test = $test + 1; 43 if (!defined $got) { 44 if ($@ =~ /^(Unsupported script encoding \Q$enc\E)/) { 45 print "ok $test # skip $1\n"; 46 } else { 47 print "not ok $test # $enc $bom $nl $name; got undef\n"; 48 } 49 } elsif ($got ne $expect) { 50 print "not ok $test # $enc $bom $nl $name; got '$got'\n"; 51 } else { 52 print "ok $test # $enc $bom $nl $name\n"; 53 } 54} 55 56for my $bom (0, 1) { 57 for my $enc (qw(UTF-16LE UTF-16BE UTF-8)) { 58 for my $nl (1, 0) { 59 for my $value (123, 1234, 12345) { 60 test($enc, $value, $value, $bom, $nl, $value); 61 # This has the unfortunate side effect of causing an infinite 62 # loop without the bug fix it corresponds to: 63 test($enc, "($value)", $value, $bom, $nl, "($value)"); 64 } 65 next if $enc eq 'UTF-8'; 66 # Arguably a bug that currently string literals from UTF-8 file 67 # handles are not implicitly "use utf8", but don't FIXME that 68 # right now, as here we're testing the input filter itself. 69 70 for my $expect ( 71 "N", "\x{010a}", "\x{0a23}", "\x{64321}", "\x{10FFFD}", 72 "\x{1000a}", # 0xD800 0xDC0A 73 "\x{12800}", # 0xD80A 0xDC00 74 # explore a bunch of bit-width boundaries 75 map { chr((1 << $_) - 1), chr(1 << $_) } 7 .. 20 76 ) { 77 # A space so that the UTF-16 heuristic triggers - " '" gives two 78 # characters of ASCII. 79 my $write = " '$expect'"; 80 my $name = 'chrs ' . join ', ', map {sprintf "%#x", ord $_} split '', $expect; 81 test($enc, $write, $expect, $bom, $nl, $name); 82 } 83 84 # This is designed to try to trip over the end of the buffer, 85 # with similar results to U-1000A and U-12800 above. 86 for my $pad (2 .. 162) { 87 for my $chr ("\x{10000}", "\x{1000a}", "\x{12800}") { 88 my $padding = ' ' x $pad; 89 # Need 4 octets that were from 2 ASCII characters to trigger 90 # the heuristic that detects UTF-16 without a BOM. For 91 # UTF-16BE, one space and the newline will do, as the 92 # newline's high octet comes first. But for UTF-16LE, a 93 # newline is "\n\0", so it doesn't trigger it. 94 test($enc, " \n$padding'$chr'", $chr, $bom, $nl, 95 sprintf "'\\x{%x}' with $pad spaces before it", ord $chr); 96 } 97 } 98 } 99 } 100} 101 102END { 103 1 while unlink "tmputf$$.pl"; 104} 105